├── LICENSE.txt ├── Makefile ├── README.2 ├── README.md ├── big-n.l ├── compile-compiler ├── compiler.lsp ├── cr1.c ├── cr2.c ├── crc.c ├── crfile.h ├── cri.c ├── errors.l ├── flags.l ├── fnames.l ├── hd.l ├── lap.lsp ├── lisp-fn.l ├── lisp-zfn.l ├── manual ├── Makefile ├── lispman.pdf ├── lispman.tex ├── reduce.sty ├── sl.bbl ├── sl.bib ├── sl.pdf └── sl.tex ├── sizes.c ├── sysid.l ├── sysids.l ├── tests ├── BigNTest.lsp └── test.lsp ├── type.l ├── types.l ├── uncrustify.config ├── yylex.l └── zfnames.l /LICENSE.txt: -------------------------------------------------------------------------------- 1 | 2 | Portable Utah Standard LISP and its associated documentation are: 3 | 4 | Copyright (c) 1990 Dr. Tugrul Yilmaz, Dr. Gokturk Ucoluk, and Ersin Karabudak 5 | All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions are 9 | met: 10 | 11 | 1. Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 14 | 2. Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # 2 | # creator of lisp 3 | # usage: 4 | # make : creates lisp. 5 | # make install : installs lisp. 6 | # make clean : cleans all the created files except executables: lisp & sizes. 7 | # make sizes : generates sizes executable, which informs about the basic data sizes. 8 | 9 | COMPILER_FILES = compc1 compe compn1 compu compx1 10 | 11 | all: lisp lispc LISP-INI 12 | 13 | lisp : lisp1.o lisp2.o crc cri 14 | gcc -ggdb -O0 -o lisp lisp1.o lisp2.o -lm 15 | 16 | lispc : lisp1c.o lisp2.o lispc1.o 17 | gcc -o $@ $^ -lm 18 | ./cri comp 19 | 20 | LISP-INI : $(COMPILER_FILES) cri 21 | ./cri comp 22 | 23 | lisp1.c : flags.l fnames.l types.l sysids.l sysid.l cr1 24 | ./cr1 25 | 26 | lisp2.c : flags.l fnames.l types.l zfnames.l errors.l hd.l yylex.l lisp-zfn.l \ 27 | lisp-fn.l type.l big-n.l sysid.l sysids.l cr2 28 | ./cr2 29 | 30 | lisp1c.c : flags.l fnames.l types.l sysids.l sysid.l cr1 $(COMPILER_FILES) 31 | ./cr1 comp $@ 32 | 33 | lispc1.c : crc flags.l types.l type.l hd.l sysids.l zfnames.l $(COMPILER_FILES) 34 | ./crc comp 35 | 36 | lisp1.o : lisp1.c 37 | gcc -ggdb -O0 -Wall -pedantic -c lisp1.c 38 | 39 | lisp2.o : lisp2.c 40 | gcc -ggdb -O0 -Wall -pedantic -Wno-parentheses -c lisp2.c 41 | 42 | $(COMPILER_FILES): compiler.lsp lap.lsp lisp 43 | ./compile-compiler 44 | 45 | cr1 : cr1.c crfile.h 46 | gcc -Wall -pedantic -o cr1 cr1.c 47 | 48 | cr2 : cr2.c crfile.h 49 | gcc -Wall -pedantic -o cr2 cr2.c 50 | 51 | crc : crc.c crfile.h 52 | gcc -Wall -pedantic -o crc crc.c 53 | 54 | cri : cri.c 55 | gcc -Wall -pedantic -o cri cri.c 56 | 57 | clean: 58 | rm -f lisp*.c *.o *~ *.bak 59 | rm -f compc1 compe compn1 compu compx1 60 | 61 | realclean: clean 62 | rm -f lisp lispc cr? LISP-INI 63 | 64 | sizes : sizes.c flags.l 65 | gcc -Wall -pedantic -o sizes sizes.c 66 | 67 | install: lisp 68 | mv lisp /usr/local/bin 69 | 70 | -------------------------------------------------------------------------------- /README.2: -------------------------------------------------------------------------------- 1 | 2 | S T D - L I S P 3 | 4 | Authors : Ersin KARABUDAK + Gokturk UCOLUK + Tugrul YILMAZ 5 | 6 | Internal Release : August 1990 7 | 8 | Public Release : April 1993 (6.0), June 1993 (6.1) 9 | 10 | Addresses : 11 | 12 | Dr. Gokturk Ucoluk, Dept. of Computer Engineering, 13 | Middle East Technical Univ., 14 | ODTU, Ankara, Turkiye 15 | Email: ucoluk@ceng.metu.edu.tr 16 | 17 | Dr. Tugrul Yilmaz, 18 | Email: tugruly@gmail.com 19 | 20 | Ersin Karabudak, LOGO Coorp., P.K. 322 Kadikoy, 21 | Istanbul, Turkiye 22 | 23 | This software can freely be distributed and used provided the following 24 | conditions: 25 | 26 | * Anyone can freely copy and use this software, provided that the 27 | names of the authors are referenced in the work the software 28 | is used for. 29 | 30 | * The parts of the code and documentation where the authors are 31 | mentioned cannot be removed. 32 | 33 | * This software is distributed as is. The authors will not 34 | take any responsibility for any bugs in it. Legally said: 35 | 36 | "The authors of this software and documentation 37 | provide them "as is" without warranty of any kind, 38 | either express or implied, including, but not 39 | limited to, warranties of fitness for a particular 40 | purpose." 41 | 42 | * Any code change will be clearly commented to indicate: 43 | 44 | (a) What change is made, 45 | (b) By whom it is made, 46 | (c) When was it made. 47 | 48 | The authors will be notified in case of a code alternation. 49 | 50 | =========================================================================== 51 | 52 | The tar file in which you have this (README) file you will have 53 | additional file with extentions ".c", ".l", ".h" ".tex" and 54 | a subdirectory named "compiler" under which there exist files 55 | with the extension ".lsp" and some files (with no extentions) 56 | with names starting with "comp". 57 | 58 | The first to do is: To get a LaTeX printout of the "lispman.tex" 59 | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 60 | 61 | If you are already a Utah-STD-LISP pro then we hope you will enjoy 62 | our work. Presumably your first wish will be getting your hands 63 | on the interpreter, so proceed by reading the "Compiler" chapter. 64 | 65 | If you are not familiar with Utah-STD-LISP then the first job to do 66 | is to get the 67 | 68 | "Standard Lisp Report" 69 | by: J. B. Marti, A. C. Hearn, M. L.Griss, and C. Griss, 70 | Published in: SIGPLAN Notices 14, No 10 (1979) 48--68, 71 | ACM, New York. 72 | 73 | This is the description of this LISP dialect. It is NOT a LISP 74 | tutor. If you are a novice in LISP then you need some other books. 75 | 76 | (We believe "Standard Lisp Report" should exist in electronic form 77 | somewhere in the reduce-library) 78 | 79 | =========================================================================== 80 | 81 | Due to incompatibilities among various systems/networks, there is a 82 | possibility that some characters in the file get replaced by others in 83 | a way which is not one-to-one. Below is a list how we see it. 84 | 85 | The first capital letter in the alphabet : A 86 | Exclamation mark : ! 87 | Backslash : \ 88 | Slash : / 89 | Caret : ^ 90 | Left square bracket : [ 91 | Right square bracket : ] 92 | Left curly brace : { 93 | Right curly brace : } 94 | Left parenthesis : ( 95 | Right paranthesis : ) 96 | Underscore : _ 97 | The "at" sign : @ 98 | The "and" sign : & 99 | Question mark : ? 100 | Quote : ' 101 | Double quote : " 102 | Vertical bar : | 103 | Number sign : # 104 | Dollar sign : $ 105 | Persentage sign : % 106 | Back quote : ` 107 | 108 | =========================================================================== 109 | 110 | The authors, will be happy to hear any comment, question, suggestion. 111 | Feel free to contact. 112 | 113 | -gokturk ucoluk 114 | 115 | ============================================================= end of README 116 | 117 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | Portable Utah Standard LISP 3 | =========================== 4 | 5 | The bulk of the system is written in C, except the compiler which is 6 | written in lisp. This system is very portable. It includes an 7 | interpreter, a compiler to C, and documentation on the standard and 8 | the implementation. Note that this is not a Common Lisp lisp dialect. 9 | It is a PSL (Portable Standard Lisp) dialect of Lisp. 10 | 11 | This system was written by: 12 | 13 | Dr. Tugrul Yilmaz 14 | Dr. Gokturk Ucoluk 15 | Ersin Karabudak 16 | 17 | It is available from: https://github.com/blakemcbride/PSL 18 | 19 | Through the years I (Blake McBride) contributed portability 20 | adjustments, build adjustments, and bug fixes. More recently, 21 | I was given permission to release the system. I performed 22 | numerous adjustments to the system which (hopefully) will 23 | make it easier to understand, build, and use. 24 | 25 | The git repository you obtained this system from starts its repository 26 | history with the code that has been distributed on their Internet site 27 | ( http://www.ceng.metu.edu.tr/~ucoluk/research/lisp/generalinfo.html ) 28 | then continues with the changes that were made by both them and me. 29 | After the joint changes were applied, I made numerous changes including 30 | code re-formatting and code changes designed to simplify the build 31 | process along with some minor corrections and enhancements. 32 | 33 | BUILDING 34 | -------- 35 | 36 | I have tested this system under 32 & 64 bit Linux and Mac. It uses 37 | gnu make but should be easy to change. The system is very portable so 38 | should be easy to get running under 32 or 64 bit Windows, especially 39 | with Cygwin. 40 | 41 | To build the interpreter just type: make lisp 42 | 43 | This will create the lisp executable. 44 | 45 | The compiler is just the regular lisp interpreter with the compiler 46 | (which is written in lisp) compiled into it. 47 | 48 | To build the compiler type: make lispc 49 | 50 | Note that the process of building anything but the raw interpreter 51 | builds an initialization file named LISP-INI. This file is specific 52 | to the related lisp executable created. This means the "lisp" program 53 | and the "lispc" program must use different LISP-INI files. This also 54 | means that "lisp" will not run after you create "lispc" because of the 55 | different LISP-INI files. (Actually "lisp", with no compiled code, 56 | doesn't need any LISP-INI at all.) If you compile in your own code, 57 | you have yet another unique LISP-INI file, and so on. 58 | 59 | COMPILING YOUR OWN PROGRAM 60 | -------------------------- 61 | 62 | If you create a lisp file named "try.lsp", it can be compiled into the 63 | system as follows: 64 | 65 | ./lispc 66 | (compilefile "try.lsp" 'try) 67 | ["anotherfile.lsp"]... be sure to use quotes 68 | end -> tryc1 trye tryn1 tryu tryx1 69 | (quit) 70 | ./cr1 try try.c -> try.c 71 | ./crc try -> lispc1.c 72 | ./cri try -> LISP-INI 73 | gcc -o try lisp2.c try.c lispc1.c -lm -> try 74 | 75 | "try" will be the complete lisp system with your code compiled in. 76 | An associated LSIP-INI file will also be created. 77 | 78 | Notes: 79 | 80 | lisp2.c has a constant name and content (ergo, lisp2.c is the same 81 | regardless of what, if anything, is compiled) 82 | 83 | lispc1.c has a constant name but the contents change based on what you 84 | are compiling 85 | 86 | Basically all of the lisp source files get compiled and combined into 87 | a single executable. You must compile all of the lisp files at the 88 | same time. Additional source files may be included in the compile by 89 | typing their file names in double-quotes one after the other when 90 | prompted by the compiler. You type "end" (without the quotes) when 91 | done. 92 | 93 | 94 | See the file "compiler-compile". It shows compiling two files. 95 | 96 | 97 | The implementation file that comes with the system (lispman) is a 98 | little out-of-date. I changed some things to streamline and simplify 99 | the build process. However, all of the internals documentation should 100 | be correct. 101 | 102 | The "sl.*" files in the "manual" directory contains the full 103 | documentation on the PSL lisp dialect that this system conforms to. 104 | 105 | 106 | Blake McBride 107 | blake@mcbridemail.com 108 | -------------------------------------------------------------------------------- /big-n.l: -------------------------------------------------------------------------------- 1 | /* Arbitrary precision arithmetic support to LISP. 2 | division is not present yet. Trieste, Italy ICTP July 31,1989 13:11 TY */ 3 | /* division added at Ankara November 3, 1989 15:45 TY */ 4 | 5 | /* umultiply multiplies two long number; result returned in x and y. 6 | lower part in y and higher part in x. */ 7 | 8 | void umultiply(x, y) 9 | long *x, *y; 10 | { 11 | longdbl z; 12 | z = longd(*x) * (*y); 13 | *x = (long) (z / BASE); 14 | *y = (long) (z - longd(*x) * BASE); 15 | } 16 | 17 | long udivide(x, y, d) 18 | long x, *y, d; /* returns remainder */ 19 | { 20 | longdbl z; 21 | if (x) { 22 | z = longd(x) * BASE + *y; 23 | *y = (long) (z / d); 24 | return (long) (z - longd(*y) * d); 25 | } else { 26 | x = *y; 27 | *y = x / d; 28 | return x % d; 29 | } 30 | } 31 | 32 | void resize(p, n, l) 33 | long **p; /* resizes the arithmetic arrays */ 34 | int *n; 35 | int l; 36 | { 37 | free(*p); 38 | *n = 3 * l / 2; 39 | *p = (long *)myalloc((*n) * sizeof(long)); 40 | } 41 | 42 | PSEXP zbig(v, n) /* prepares new cell for big number */ 43 | long v; 44 | PSEXP n; 45 | { 46 | PSEXP z; 47 | z = Sexp(zalloc(Tbig)); 48 | type(z) = Tbig; 49 | bigval(z) = v; 50 | bigcdr(z) = n; 51 | return z; 52 | } 53 | 54 | long zintval(xp, dz) /* ascii string of dz numbers pointed by xp --> bin number */ 55 | char *xp; 56 | int dz; 57 | { 58 | long j = 0; 59 | int k; 60 | 61 | for (k = 1 ; k <= dz ; k++) 62 | j = 10 * j + *xp++ - '0'; 63 | return j; 64 | } 65 | 66 | void zbigint() 67 | { 68 | int i, j, l = 0; /* parser of big numbers */ 69 | int sg = 0, s = 1; 70 | 71 | reg1 = NIL; 72 | if (yytext[0] == '-') { 73 | s = -1; 74 | sg = 1; 75 | } else if (yytext[0] == '+') 76 | sg = 1; 77 | j = digitcnt - DZ + sg; 78 | while (1) { 79 | reg1 = zbig(zintval(yytext + j, DZ), reg1); 80 | l++; 81 | if ((i = j - DZ) >= sg) 82 | j = i; 83 | else 84 | break; 85 | } 86 | if ((j -= sg)) { 87 | reg1 = zbig(zintval(yytext + sg, j), reg1); 88 | l++; 89 | } 90 | reg1 = zbig((long) s * l, reg1); 91 | } 92 | 93 | double zbig2float(x) /* big to float conversion */ 94 | PSEXP x; 95 | { 96 | int i, j, l, s = 1; 97 | double r = 0.0; 98 | 99 | if ((l = (int)bigval(x)) < 0) 100 | s = -1; 101 | l = abs(l); 102 | j = min(l, 4); 103 | for (i = 0 ; i < j ; i++) { 104 | x = bigcdr(x); 105 | r = r * BASE + bigval(x); 106 | } 107 | for (i = j ; i < l ; i++) 108 | r = r * BASE; 109 | return s * r; 110 | } 111 | 112 | void znormalize(x) /* checks the number sizes and put them in */ 113 | long x; /* single cell if possible */ 114 | { 115 | long x1; 116 | 117 | x1 = labs(x); 118 | if (x1 < BASE) 119 | reg1 = zinteger(x); 120 | else { 121 | reg1 = zbig(x1 % BASE, NIL); 122 | reg1 = zbig(x1 / BASE, reg1); 123 | reg1 = zbig( x < 0 ? -2L : 2L, reg1); 124 | } 125 | } 126 | 127 | void zfnormalize(x) /* checks the number sizes and put them in */ 128 | longdbl x; /* single cell if possible */ 129 | { 130 | int s; 131 | long a; 132 | longdbl dd; 133 | 134 | if (x < 0.0) { 135 | dd = -x; 136 | s = -2; 137 | } else { 138 | dd = x; 139 | s = 2; 140 | } 141 | if (dd < BASE) 142 | reg1 = zinteger((long)x); 143 | else { 144 | a = (long) (dd / BASE); 145 | reg1 = zbig((long)(dd - longd(a) * BASE), NIL); 146 | reg1 = zbig(a, reg1); 147 | reg1 = zbig((long)s, reg1); 148 | } 149 | } 150 | 151 | void zmultiply() /* arbitrary precision integer multiplication */ 152 | { 153 | long a, b, rl, rh, s, *np; 154 | int l1, l2, l, i, j, u = -1; 155 | 156 | if (fixp(reg1)) { 157 | a = intval(reg1); 158 | if (fixp(reg2)) { 159 | zfnormalize(longd(a) * intval(reg2)); /* normal multiplication */ 160 | return; 161 | } 162 | if (a == 1) { 163 | reg1 = reg2; 164 | return; 165 | } 166 | if (a == 0) 167 | return; 168 | *arit1 = labs(a); /* placement of big numbers into arrays. access is quicker */ 169 | l1 = 0; 170 | } else { 171 | a = bigval(reg1); 172 | l1 = labs(a) - 1; 173 | if (arit1sz <= l1) 174 | resize(&arit1, &arit1sz, l1); 175 | np = arit1 + l1; 176 | for (i = 0 ; i <= l1 ; i++) { 177 | reg1 = bigcdr(reg1); 178 | *np-- = bigval(reg1); 179 | } 180 | } 181 | if (fixp(reg2)) { 182 | b = intval(reg2); 183 | if (b == 1) 184 | return; 185 | if (b == 0) { 186 | reg1 = reg2; 187 | return; 188 | } 189 | *arit2 = labs(b); 190 | l2 = 0; 191 | } else { 192 | b = bigval(reg2); 193 | l2 = labs(b) - 1; 194 | if (arit2sz <= l2) 195 | resize(&arit2, &arit2sz, l2); 196 | np = arit2 + l2; 197 | for (i = 0 ; i <= l2 ; i++) { 198 | reg2 = bigcdr(reg2); 199 | *np-- = bigval(reg2); 200 | } 201 | } 202 | if (a < 0) 203 | s = -1; 204 | else 205 | s = 1; /* carry sign separately */ 206 | if (b < 0) 207 | s *= -1; 208 | l = l1 + l2; 209 | reg1 = NIL; 210 | rl = rh = 0; 211 | for (i = 0 ; i <= l ; i++) { /* beginning point of multiplication */ 212 | if (i <= l2) 213 | u++; 214 | j = i > l1 ? i - l1 : 0; 215 | np = arit1 + i; 216 | do { 217 | a = *(np - j); 218 | b = *(arit2 + j); 219 | umultiply(&a, &b); 220 | rl += b; 221 | rh += a + rl / BASE; 222 | rl %= BASE; 223 | } while (++j <= u); 224 | reg1 = zbig(rl, reg1); 225 | rl = rh % BASE; 226 | rh /= BASE; 227 | } 228 | if (rl) { 229 | reg1 = zbig(rl, reg1); 230 | l++; 231 | } 232 | if (rh) { 233 | reg1 = zbig(rh, reg1); 234 | l++; 235 | } 236 | reg1 = zbig((long)(s * (l + 1)), reg1); 237 | } /* end of zmultiply */ 238 | 239 | 240 | void zexpt() 241 | { 242 | long a; 243 | int i; 244 | 245 | if (fixp(reg1)) { 246 | if ((a = intval(reg1)) == 1 || a == 0) 247 | return; 248 | if (a == -1) { 249 | if (fixp(reg2)) { 250 | if (!(intval(reg2) & 1)) 251 | goto r1; 252 | } else { 253 | i = abs((int)bigval(reg2)); 254 | while (i-- >= 0) 255 | reg2 = bigcdr(reg2); 256 | if (!(bigval(reg2) & 1)) 257 | goto r1; 258 | } 259 | return; 260 | } 261 | } 262 | if (bigp(reg2)) { 263 | if (bigval(reg2) < 0) 264 | goto r0; 265 | else 266 | zerror(41); 267 | } 268 | if ((a = intval(reg2)) < 0) 269 | goto r0; 270 | else if (a == 0) 271 | goto r1; 272 | else if (a == 1) 273 | return; 274 | else { 275 | kalloc(2); 276 | kset(1, reg1); 277 | i = 1; 278 | while (a > 0) { 279 | if (a & 1) { 280 | if (i) { 281 | local0 = local(1); 282 | i = 0; 283 | } else { 284 | reg1 = local0; 285 | reg2 = local(1); 286 | zmultiply(); 287 | local0 = reg1; 288 | } 289 | } 290 | a = a >> 1; 291 | if (a > 0) { 292 | reg1 = reg2 = local(1); 293 | zmultiply(); 294 | kset(1, reg1); 295 | } 296 | } 297 | } 298 | reg1 = local0; 299 | kpop(2); 300 | return; 301 | r1: 302 | reg1 = Sexp(&ONE); 303 | return; 304 | r0: 305 | reg1 = Sexp(&ZERO); 306 | } 307 | 308 | #define addon(E) z = bigcdr(z) = zbig(E, NIL) 309 | #define laydown if (e > 0) { addon(e); } else if (z == Sexp(&dummybig)) \ 310 | l--; \ 311 | else { addon(e); } \ 312 | if (k > 0) \ 313 | do { addon(d); } while (--k != 0) 314 | #define exchange dd = reg1; reg1 = reg2; reg2 = dd; l1 = 2 * l2 - l1 315 | 316 | void zaddsub(s) 317 | int s; 318 | { 319 | long h, e, d; 320 | int l1, l2, l, k = 0, s1 = 1; 321 | PSEXP dd, z; 322 | 323 | if (fixp(reg1)) { 324 | l1 = 1; 325 | h = intval(reg1); 326 | reg1 = zbig(labs(h), NIL); 327 | } else { 328 | h = bigval(reg1); 329 | l1 = labs(h); 330 | reg1 = bigcdr(reg1); 331 | } 332 | if (h < 0) { 333 | s1 = -1; 334 | s *= -1; 335 | } 336 | if (fixp(reg2)) { 337 | l2 = 1; 338 | e = intval(reg2); 339 | reg2 = zbig(labs(e), NIL); 340 | } else { 341 | e = bigval(reg2); 342 | l2 = labs(e); 343 | reg2 = bigcdr(reg2); 344 | } 345 | if (e < 0) 346 | s *= -1; 347 | e = 0L; 348 | z = Sexp(&dummybig); 349 | l = l1 > l2 ? l1 : l2; /* max of l1,l2 */ 350 | if (s > 0) { 351 | if (l1 < l2) { 352 | exchange; 353 | } 354 | do { 355 | if (l2 < l1) { 356 | h = bigval(reg1); 357 | l2++; 358 | } else { 359 | h = bigval(reg1) + bigval(reg2); 360 | reg2 = bigcdr(reg2); 361 | } 362 | if (h == BM1) 363 | k++; 364 | else { 365 | if (h > BM1) { 366 | h -= BASE; 367 | e++; 368 | d = 0L; 369 | } else 370 | d = BM1; 371 | laydown; 372 | e = h; 373 | } 374 | } while ((reg1 = bigcdr(reg1)) != NIL); 375 | d = BM1; 376 | } else { /* if s<0 */ 377 | if (l1 == l2) { 378 | while (bigval(reg1) == bigval(reg2)) { 379 | if (--l == 0) { 380 | reg1 = Sexp(&ZERO); 381 | return; 382 | } 383 | reg1 = bigcdr(reg1); 384 | reg2 = bigcdr(reg2); 385 | } 386 | l1 = l2 = l; 387 | if (bigval(reg1) < bigval(reg2)) { 388 | exchange; 389 | s1 = -s1; 390 | } 391 | } else if (l1 < l2) { 392 | exchange; 393 | s1 = -s1; 394 | } 395 | do { 396 | if (l2 < l1) { 397 | h = bigval(reg1); 398 | l2++; 399 | } else { 400 | h = bigval(reg1) - bigval(reg2); 401 | reg2 = bigcdr(reg2); 402 | } 403 | if (h == 0) 404 | k++; 405 | else { 406 | if (h < 0) { 407 | h += BASE; 408 | e--; 409 | d = BM1; 410 | } else 411 | d = 0L; 412 | laydown; 413 | e = h; 414 | } 415 | } while ((reg1 = bigcdr(reg1)) != NIL); 416 | d = 0; 417 | } /* end of else in case of s<0 */ 418 | laydown; 419 | if (l == 0) 420 | reg1 = zinteger(bigval(dummybig.Xcdr) * s1); 421 | else 422 | reg1 = zbig((long)((l + 1) * s1), dummybig.Xcdr); 423 | dummybig.Xcdr = NIL; /* clear memory */ 424 | } 425 | #undef addon 426 | #undef laydown 427 | #undef exchange 428 | 429 | #define addon(Q) if (Q > 0) \ 430 | z = bigcdr(z) = zbig(Q, NIL); \ 431 | else if (z == Sexp(&dummybig)) \ 432 | l--; else \ 433 | z = bigcdr(z) = zbig(Q, NIL) 434 | 435 | 436 | void zdivision(p) /* arbitrary precision integer division */ 437 | int p; /* p == 0 ===> remainder */ 438 | { 439 | long a, b, rl, s, q, v, u, *np; /* p == 1 ===> quotient */ 440 | int l1, l2, l, i, j, k; /* p == 2 ===> divide */ 441 | PSEXP z; 442 | longdbl e, d; 443 | 444 | if (fixp(reg1)) { 445 | a = intval(reg1); 446 | if (fixp(reg2)) { 447 | b = intval(reg2); 448 | if (p != 1) { 449 | reg1 = zinteger(a % b); 450 | if (p == 2) { 451 | reg2 = zinteger(a / b); 452 | Xcons(); 453 | } 454 | return; 455 | } 456 | reg1 = zinteger(a / b); 457 | return; 458 | } else { /* division of small # by big # */ 459 | if (p == 0) 460 | return; 461 | if (p == 2) 462 | reg2 = reg1; 463 | reg1 = Sexp(&ZERO); 464 | if (p == 1) 465 | return; 466 | Cons(); 467 | return; 468 | } 469 | } else { 470 | if ((a = bigval(reg1)) < 0) { /* first argument is big */ 471 | l1 = -(int)a; 472 | s = -1; 473 | } else { 474 | l1 = (int)a; 475 | s = 1; 476 | } 477 | reg1 = bigcdr(reg1); 478 | } 479 | z = Sexp(&dummybig); 480 | if (fixp(reg2)) { /* first argument is big */ 481 | b = intval(reg2); 482 | if (b < 0) 483 | s = -s; 484 | b = labs(b); 485 | l = l1; 486 | v = 0; /*remainder*/ 487 | do { 488 | rl = bigval(reg1); 489 | v = udivide(v, &rl, b); 490 | if (p > 0) { 491 | addon(rl); 492 | } 493 | reg1 = bigcdr(reg1); 494 | } while (reg1 != NIL); 495 | if (p != 1) { 496 | reg1 = zinteger(v); 497 | if (p) 498 | reg2 = reg1; 499 | else 500 | return; 501 | } 502 | } else { /* both arguments are big */ 503 | b = bigval(reg2); 504 | if (b < 0) 505 | s = -s; 506 | l2 = abs((int)b); 507 | l = l1 - l2 + 1; 508 | if (arit2sz <= l2 + 2) 509 | resize(&arit2, &arit2sz, l2 + 2); 510 | np = arit2 + l2; 511 | for (i = 1 ; i <= l2 ; i++) { 512 | reg2 = bigcdr(reg2); 513 | *np-- = bigval(reg2); 514 | } 515 | if (arit1sz <= l1 + 2) 516 | resize(&arit1, &arit1sz, l1 + 2); 517 | np = arit1 + l1; 518 | arit1[0] = arit1[l1 + 1] = arit2[0] = 0; 519 | for (i = 1 ; i < l1 ; i++) { 520 | *np-- = bigval(reg1); 521 | reg1 = bigcdr(reg1); 522 | } 523 | *np = bigval(reg1); 524 | d = arit2[l2 - 1] + longd(arit2[l2]) * BASE; 525 | for (i = l1 ; i >= l2 ; i--) { 526 | e = (longd(arit1[i + 1]) * BASE) / d; 527 | q = (long)((longd(arit1[i - 1]) + longd(arit1[i]) * BASE) / d + e * BASE + 0.5); 528 | u = 0; 529 | k = i - l2; 530 | for (j = 1 ; j <= l2 ; j++) { 531 | k++; 532 | e = longd(arit2[j]) * q + u; 533 | u = (long) (e / BASE); 534 | v = arit1[k] - (long) (e - longd(u) * BASE); 535 | if (v < 0) { 536 | u++; 537 | v += BASE; 538 | } 539 | arit1[k] = v; 540 | } 541 | if (arit1[k + 1] < u) { 542 | q--; 543 | k = i - l2; 544 | u = 0; 545 | for (j = 1 ; j <= l2 ; j++) { 546 | k++; 547 | v = arit1[k] + arit2[j] + u; 548 | if (v < BASE) 549 | u = 0; 550 | else { 551 | u = 1; 552 | v = v - BASE; 553 | } 554 | arit1[k] = v; 555 | } 556 | } 557 | arit1[k + 1] = 0; 558 | if (p > 0) { 559 | addon(q); 560 | } 561 | } 562 | if (p != 1) { /*get remainder in arith1 */ 563 | np = arit1; 564 | *np = 1; 565 | np += l2; 566 | while (*np-- == 0) 567 | l2--; 568 | np = arit1 + 1; 569 | if (l2 > 1) { 570 | reg1 = NIL; 571 | for (j = 1 ; j <= l2 ; j++) 572 | reg1 = zbig(*np++, reg1); 573 | reg1 = zbig((long)l2, reg1); 574 | } else if (l2 == 1) 575 | reg1 = zinteger(arit1[1]); 576 | else 577 | reg1 = Sexp(&ZERO); 578 | if (p) 579 | reg2 = reg1; 580 | else 581 | return; 582 | } 583 | 584 | } 585 | if (z == Sexp(&dummybig)) 586 | reg1 = Sexp(&ZERO); 587 | else { 588 | reg1 = dummybig.Xcdr; 589 | dummybig.Xcdr = NIL; 590 | if (l > 1) 591 | reg1 = zbig((long)s * l, reg1); 592 | else 593 | reg1 = zinteger(s * bigval(reg1)); 594 | } 595 | if (p == 2) 596 | Cons(); 597 | } /* end of zdivision */ 598 | 599 | #undef addon 600 | -------------------------------------------------------------------------------- /compile-compiler: -------------------------------------------------------------------------------- 1 | # 2 | ./lisp < 2 | #include 3 | #include 4 | 5 | #include "flags.l" 6 | #include "crfile.h" 7 | 8 | 9 | char outfile[100]; 10 | char hsh[128][50]; 11 | char nm[32], pnm[32], tp[20], val[32], compn1[30], compn[30], argv1[30]; 12 | char ln[132], *buf, *obuf; 13 | int i, func_cnt, k, no, hs; 14 | #if BITF 15 | int x1, x2, x3, x4, x5, x6; 16 | #else 17 | int x1; 18 | #endif 19 | FILE *in_file, *out_file; 20 | 21 | int hash(xx) 22 | char *xx; 23 | { 24 | int h; 25 | h = 0; 26 | while (*xx) 27 | h += *(xx++); 28 | return h % 128; 29 | } 30 | 31 | void filecopy() 32 | { 33 | int c; 34 | 35 | while ((c = getc(in_file)) != EOF) 36 | putc(c, out_file); 37 | fprintf(out_file, "\n"); 38 | fclose(in_file); 39 | } 40 | 41 | void file_open(file_name) 42 | char *file_name; 43 | { 44 | in_file = fopen(file_name, "r"); 45 | if (in_file == NULL) { 46 | printf("\n File not found: "); 47 | printf("%s", file_name); 48 | printf("\n"); 49 | exit(1); 50 | } 51 | setvbuf(in_file, buf, _IOFBF, 16000); 52 | } 53 | 54 | int main(argc, argv) 55 | int argc; 56 | char *argv[]; 57 | { 58 | if (argc == 1) { 59 | strcpy(outfile, "lisp1.c"); 60 | strcpy(argv1, "~~~"); /* force user to use "comp" argument when building for the compiler */ 61 | } else if (argc != 3) { 62 | fprintf(stderr, "Usage: cr1 [ ]\n"); 63 | exit(1); 64 | } else { 65 | strcpy(argv1, argv[1]); 66 | strcpy(outfile, argv[2]); 67 | } 68 | strcpy(compn, argv1); 69 | strcat(compn, "n"); 70 | strcpy(compn1, argv1); 71 | strcat(compn1, "n1"); 72 | buf = (char *)malloc(16000); 73 | obuf = (char *)malloc(20000); 74 | out_file = fopen(outfile, "w"); 75 | if (obuf != NULL) 76 | setvbuf(out_file, obuf, _IOFBF, 20000); 77 | #if _TURBOC_ 78 | fprintf(out_file, "\nextern unsigned _stklen = 10000;\n"); /*used by turboc */ 79 | #endif 80 | /* FLAGS */ 81 | file_open(flags); 82 | filecopy(); 83 | 84 | /* TYPES AND MACROS */ 85 | file_open(types); 86 | filecopy(); 87 | /* file_open(type); 88 | filecopy(); */ 89 | 90 | /* QUOTE */ 91 | 92 | file_open(fnames); 93 | i = 0; 94 | while (fscanf(in_file, "%s%s%d%s", nm, pnm, &no, tp) != EOF) { 95 | if (strcmp(nm, "quote") == 0) { 96 | fprintf(out_file, "#define quote (Sexp(&fname[%d]))\n", i); 97 | break; 98 | } 99 | i++; 100 | } 101 | fclose(in_file); 102 | 103 | /* URWELT ARRAY */ 104 | strcpy(nm, argv1); 105 | strcat(nm, "u"); 106 | in_file = fopen(nm, "r"); 107 | if (in_file != NULL) { 108 | setvbuf(in_file, buf, _IOFBF, 16000); 109 | fscanf(in_file, "%d", &no); 110 | fclose(in_file); 111 | fprintf(out_file, "PSEXP urwelt[%d];\n", no); 112 | } else { 113 | no = 0; 114 | fprintf(out_file, "PSEXP urwelt[1];\n"); 115 | } 116 | fprintf(out_file, "unsigned ursize = %d;\n", no); 117 | 118 | /* FUNCTION COUNTING */ 119 | 120 | file_open(fnames); 121 | func_cnt = 0; 122 | fprintf(out_file, "\nvoid "); 123 | while (fscanf(in_file, "%s%s%d%s", nm, pnm, &no, tp) != EOF) { 124 | if (func_cnt != 0) 125 | fprintf(out_file, ","); 126 | if (func_cnt % 6 == 0) 127 | fprintf(out_file, "\n "); 128 | strcat(pnm, "()"); 129 | fprintf(out_file, " %s", pnm); 130 | func_cnt++; 131 | } 132 | fclose(in_file); 133 | i = 2; 134 | in_file = fopen(compn1, "r"); 135 | while (in_file != NULL) { 136 | setvbuf(in_file, buf, _IOFBF, 16000); 137 | while (fscanf(in_file, "%s%s%d%s", nm, pnm, &no, tp) != EOF) { 138 | if (func_cnt != 0) 139 | fprintf(out_file, ","); 140 | if (func_cnt % 6 == 0) 141 | fprintf(out_file, "\n "); 142 | strcat(pnm, "()"); 143 | fprintf(out_file, " %s", pnm); 144 | func_cnt++; 145 | } 146 | fclose(in_file); 147 | sprintf(tp, "%d", i); 148 | i++; 149 | strcpy(ln, compn); 150 | strcat(ln, tp); 151 | /* strcat(ln,"."); */ 152 | in_file = fopen(ln, "r"); 153 | } 154 | fprintf(out_file, ";\n"); 155 | 156 | for (i = 0 ; i < 128 ; i++) 157 | strcpy(hsh[i], "NULL"); 158 | 159 | /* ASCII CONTROL CHARACTER STRINGS */ 160 | 161 | fprintf(out_file, "\nchar asciich[32][2] = {"); 162 | for (i = 0 ; i < ' ' ; i++) 163 | fprintf(out_file, "\n { '\\%o', '\\0' },", i); 164 | fprintf(out_file, " };\n"); 165 | fprintf(out_file, "char ascii127[2] = { '\\127', '\\0' };\n"); 166 | 167 | /* SYSTEM IDENTIFIERS */ 168 | 169 | file_open(sysids); 170 | fprintf(out_file, "\n"); 171 | #if BITF 172 | while (fscanf(in_file, "%s%d%d%d%d%d%d%s%s", 173 | nm, &x1, &x2, &x3, &x4, &x5, &x6, pnm, val) != EOF) { 174 | hs = hash(pnm); 175 | fprintf(out_file, 176 | "ID %s = {Tid, %d,%d,%d,%d,%d,%d, %s, %s, NIL, \"%s\" };\n", 177 | nm, x1, x2, x3, x4, x5, x6, hsh[hs], val, pnm); 178 | sprintf(hsh[hs], "&%s", nm); 179 | } 180 | #else 181 | while (fscanf(in_file, "%s%d%s%s", nm, &x1, pnm, val) != EOF) { 182 | hs = hash(pnm); 183 | fprintf(out_file, "ID %s = {Tid, %d, %s, %s, NIL, \"%s\" };\n", 184 | nm, x1, hsh[hs], val, pnm); 185 | sprintf(hsh[hs], "&%s", nm); 186 | } 187 | #endif 188 | fclose(in_file); 189 | 190 | /* CHARACTER IDENTIFIERS */ 191 | 192 | fprintf(out_file, "\nID chrid[128] = {\n"); 193 | for (i = 0 ; i < 127 ; i++) { 194 | if (i < ' ') 195 | #if BITF 196 | fprintf(out_file, 197 | " {Tid, 0,0,0,0,1,0, %s, NULL, NIL, asciich[%d] },\n" 198 | , hsh[i], i); 199 | else if (i == 't') 200 | fprintf(out_file, 201 | " {Tid, 0,1,0,0,1,0, %s, Sexp(&chrid['t']), NIL, \"%c\" },\n" 202 | , hsh[i], i); 203 | else if (i == '"' || i == '\\') 204 | fprintf(out_file, " {Tid, 0,0,0,0,1,0, %s, NULL, NIL, \"\\%c\" },\n" 205 | , hsh[i], i); 206 | else 207 | fprintf(out_file, " {Tid, 0,0,0,0,1,0, %s, NULL, NIL, \"%c\" },\n" 208 | , hsh[i], i); 209 | sprintf(hsh[i], "&chrid[%d]", i); 210 | } 211 | fprintf(out_file, " {Tid, 0,0,0,0,1,0, %s, NULL, NIL, ascii127 } };\n" 212 | , hsh[127]); 213 | #else 214 | fprintf(out_file, " {Tid, 2, %s, NULL, NIL, asciich[%d] },\n" 215 | , hsh[i], i); 216 | else if (i == 't') 217 | fprintf(out_file, " {Tid, 18, %s, Sexp(&chrid['t']), NIL, \"%c\" },\n" 218 | , hsh[i], i); 219 | else if (i == '"' || i == '\\') 220 | fprintf(out_file, " {Tid, 2, %s, NULL, NIL, \"\\%c\" },\n" 221 | , hsh[i], i); 222 | else 223 | fprintf(out_file, " {Tid, 2, %s, NULL, NIL, \"%c\" },\n" 224 | , hsh[i], i); 225 | sprintf(hsh[i], "&chrid[%d]", i); 226 | } 227 | fprintf(out_file, " {Tid, 2, %s, NULL, NIL, ascii127 } };\n" 228 | , hsh[127]); 229 | #endif 230 | strcpy(hsh[127], "&chrid[127]"); 231 | 232 | /* FUNCTION POINTERS */ 233 | 234 | file_open(fnames); 235 | fprintf(out_file, "\nFPOINTER fnpntr[%d] = {", func_cnt); 236 | while (fscanf(in_file, "%s%s%d%s", nm, pnm, &no, tp) != EOF) { 237 | fprintf(out_file, "\n { Tfpointer, %d, %s },", no, pnm); 238 | } 239 | fclose(in_file); 240 | in_file = fopen(compn1, "r"); 241 | k = 2; 242 | while (in_file != NULL) { 243 | setvbuf(in_file, buf, _IOFBF, 16000); 244 | while (fscanf(in_file, "%s%s%d%s", nm, pnm, &no, tp) != EOF) { 245 | fprintf(out_file, "\n { Tfpointer, %d, %s },", no, pnm); 246 | } 247 | fclose(in_file); 248 | sprintf(tp, "%d", k); 249 | k++; 250 | strcpy(ln, compn); 251 | strcat(ln, tp); 252 | /* strcat(ln,"."); */ 253 | in_file = fopen(ln, "r"); 254 | } 255 | fprintf(out_file, " };\n"); 256 | 257 | /* FUNCTION VALUE PAIRS */ 258 | 259 | fprintf(out_file, "\nint NOFPAIR = %d;\n", func_cnt); 260 | 261 | file_open(fnames); 262 | i = 0; 263 | fprintf(out_file, "\nPAIR fnvlpr[%d] = {", func_cnt); 264 | while (fscanf(in_file, "%s%s%d%s", nm, pnm, &no, tp) != EOF) { 265 | fprintf(out_file, "\n { Tpair, Sexp(&%s), Sexp(&fnpntr[%d]) },", tp, i); 266 | i++; 267 | } 268 | fclose(in_file); 269 | in_file = fopen(compn1, "r"); 270 | k = 2; 271 | while (in_file != NULL) { 272 | setvbuf(in_file, buf, _IOFBF, 16000); 273 | while (fscanf(in_file, "%s%s%d%s", nm, pnm, &no, tp) != EOF) { 274 | fprintf(out_file, "\n { Tpair, Sexp(&%s), Sexp(&fnpntr[%d]) },", tp, i); 275 | i++; 276 | } 277 | fclose(in_file); 278 | sprintf(tp, "%d", k); 279 | k++; 280 | strcpy(ln, compn); 281 | strcat(ln, tp); 282 | /* strcat(ln,"."); */ 283 | in_file = fopen(ln, "r"); 284 | } 285 | fprintf(out_file, " };\n"); 286 | 287 | /* FUNCTION NAME IDENTIFIERS */ 288 | 289 | file_open(fnames); 290 | i = 0; 291 | fprintf(out_file, "\nID fname[%d] = {", func_cnt); 292 | while (fscanf(in_file, "%s%s%d%s", nm, pnm, &no, tp) != EOF) { 293 | hs = hash(nm); 294 | #if BITF 295 | fprintf(out_file, 296 | " {Tid, 0,0,0,1,1,0, %s, Sexp(&fnvlpr[%d]), NIL, \"%s\" },\n" 297 | , hsh[hs], i, nm); 298 | #else 299 | fprintf(out_file, " {Tid, 6, %s, Sexp(&fnvlpr[%d]), NIL, \"%s\" },\n" 300 | , hsh[hs], i, nm); 301 | #endif 302 | sprintf(hsh[hs], "&fname[%d]", i); 303 | i++; 304 | } 305 | fclose(in_file); 306 | k = 2; 307 | in_file = fopen(compn1, "r"); 308 | while (in_file != NULL) { 309 | setvbuf(in_file, buf, _IOFBF, 16000); 310 | while (fscanf(in_file, "%s%s%d%s", nm, pnm, &no, tp) != EOF) { 311 | hs = hash(nm); 312 | #if BITF 313 | fprintf(out_file, 314 | " {Tid, 0,0,0,1,1,0, %s, Sexp(&fnvlpr[%d]), NIL, \"%s\" },\n" 315 | , hsh[hs], i, nm); 316 | #else 317 | fprintf(out_file, 318 | " {Tid, 6, %s, Sexp(&fnvlpr[%d]), NIL, \"%s\" },\n" 319 | , hsh[hs], i, nm); 320 | #endif 321 | sprintf(hsh[hs], "&fname[%d]", i); 322 | i++; 323 | } 324 | fclose(in_file); 325 | sprintf(tp, "%d", k); 326 | k++; 327 | strcpy(ln, compn); 328 | strcat(ln, tp); 329 | /* strcat(ln,"."); */ 330 | in_file = fopen(ln, "r"); 331 | } 332 | fprintf(out_file, " };\n"); 333 | 334 | 335 | /* HASH TABLE */ 336 | 337 | fprintf(out_file, "\nPID hashtab[128] = {"); 338 | for (i = 0 ; i < 128 ; i++) { 339 | if (i % 4 == 0) 340 | fprintf(out_file, "\n"); 341 | strcat(hsh[i], ","); 342 | fprintf(out_file, " %s", hsh[i]); 343 | } 344 | fprintf(out_file, " };\n"); 345 | fclose(out_file); 346 | exit(0); 347 | } /*end of main */ 348 | -------------------------------------------------------------------------------- /cr2.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "flags.l" 5 | #include "crfile.h" 6 | 7 | #define outfile "lisp2.c" 8 | 9 | 10 | char nm[32], pnm[32], tp[30], val[32]; 11 | char ln[132], *buf, *obuf; 12 | int i, j, k, no, hs; 13 | FILE *in_file, *out_file; 14 | #if BITF 15 | int x1, x2, x3, x4, x5, x6; 16 | #else 17 | int x1; 18 | #endif 19 | 20 | void filecopy() 21 | { 22 | int c; 23 | 24 | while ((c = getc(in_file)) != EOF) 25 | putc(c, out_file); 26 | fprintf(out_file, "\n"); 27 | fclose(in_file); 28 | } 29 | 30 | void file_open(file_name) 31 | char *file_name; 32 | { 33 | in_file = fopen(file_name, "r"); 34 | if (in_file == NULL) { 35 | printf("\n File not found: "); 36 | printf("%s", file_name); 37 | printf("\n"); 38 | exit(1); 39 | } 40 | setvbuf(in_file, buf, _IOFBF, 16000); 41 | } 42 | 43 | void filecopy1() 44 | { 45 | int c; 46 | int n; 47 | 48 | n = 0; 49 | while ((c = getc(in_file)) != EOF) 50 | if ( c == '@') 51 | fprintf(out_file, "Sexp(&fname[%d])", n); 52 | else if ( c == '$') 53 | fprintf(out_file, "%d", n); 54 | else if ( c == '/') { 55 | putc(c, out_file); 56 | c = getc(in_file); 57 | if ( c == EOF) 58 | break; 59 | putc(c, out_file); 60 | if ( c == '*') { 61 | c = getc(in_file); 62 | if ( c == EOF) 63 | break; 64 | putc(c, out_file); 65 | if ( c == '@') { 66 | n++; 67 | fprintf(out_file, "*/\nvoid "); 68 | getc(in_file); 69 | getc(in_file); 70 | getc(in_file); 71 | } 72 | } 73 | } else 74 | putc(c, out_file); 75 | fprintf(out_file, "\n"); 76 | fclose(in_file); 77 | } 78 | 79 | int main() 80 | { 81 | buf = (char *)malloc(16000); /* set larger buffers for IO operations */ 82 | obuf = (char *)malloc(20000); 83 | out_file = fopen(outfile, "w"); 84 | if (obuf != NULL) 85 | setvbuf(out_file, obuf, _IOFBF, 20000); 86 | 87 | /* FLAGS */ 88 | file_open(flags); 89 | filecopy(); 90 | 91 | /* TYPES AND MACROS */ 92 | file_open(types); 93 | filecopy(); 94 | file_open(type); 95 | filecopy(); 96 | /* QUOTE */ 97 | 98 | file_open(fnames); 99 | i = 0; 100 | while (fscanf(in_file, "%s%s%d%s", nm, pnm, &no, tp) != EOF) { 101 | if (strcmp(nm, "quote") == 0) { 102 | fprintf(out_file, "#define quote (Sexp(&fname[%d]))\n", i); 103 | break; 104 | } 105 | i++; 106 | } 107 | fclose(in_file); 108 | 109 | /* URWELT ARRAY */ 110 | 111 | fprintf(out_file, "extern PSEXP urwelt[];\n"); 112 | fprintf(out_file, "extern unsigned ursize;\n"); 113 | fprintf(out_file, "extern PPAIR fnvlpr[];\n"); 114 | 115 | /* SYSTEM IDENTIFIERS */ 116 | 117 | file_open(sysids); 118 | fprintf(out_file, "\n"); 119 | #if BITF 120 | while (fscanf(in_file, "%s%d%d%d%d%d%d%s%s", 121 | nm, &x1, &x2, &x3, &x4, &x5, &x6, pnm, val) != EOF) 122 | #else 123 | while (fscanf(in_file, "%s%d%s%s", nm, &x1, pnm, val) != EOF) 124 | #endif 125 | fprintf(out_file, "extern ID %s; \n", nm); 126 | fclose(in_file); 127 | 128 | /* CHARACTER IDENTIFIERS */ 129 | 130 | fprintf(out_file, "\nextern ID chrid[128];\n"); 131 | 132 | /* FUNCTION NAME IDENTIFIERS */ 133 | 134 | fprintf(out_file, "\nextern ID fname[];\n"); 135 | 136 | /* HASH TABLE */ 137 | 138 | fprintf(out_file, "\nextern PID hashtab[128];\n"); 139 | 140 | /* ERROR MESSAGES */ 141 | 142 | file_open(errors); 143 | fprintf(out_file, "\nchar *emessages[] = {"); 144 | while (fgets(ln, 80, in_file) != NULL) { 145 | ln[strlen(ln) - 1] = 0; 146 | fprintf(out_file, "\n \"%s\",", ln); 147 | } 148 | fprintf(out_file, " };\n"); 149 | fclose(in_file); 150 | 151 | /* HEADER DECLARATIONS */ 152 | 153 | file_open(header); 154 | filecopy(); 155 | 156 | /* FUNCTION DECLARATIONS */ 157 | 158 | file_open(fnames); 159 | fprintf(out_file, "\nextern void"); 160 | j = 0; 161 | while (fscanf(in_file, "%s%s%d%s", nm, pnm, &no, tp) != EOF) { 162 | if (j != 0) 163 | fprintf(out_file, ","); 164 | if (j % 6 == 0) 165 | fprintf(out_file, "\n "); 166 | strcat(pnm, "()"); 167 | fprintf(out_file, " %s", pnm); 168 | j++; 169 | } 170 | fclose(in_file); 171 | fprintf(out_file, ";\n"); 172 | 173 | /* AUXILIARY FUNCTION declarations */ 174 | 175 | file_open(zfnames); 176 | fprintf(out_file, "\n"); 177 | while (fscanf(in_file, "%s%s", tp, nm) != EOF) 178 | fprintf(out_file, "%s %s();\n", tp, nm); 179 | fclose(in_file); 180 | 181 | /* TOKENIZER */ 182 | 183 | file_open(yylex); 184 | filecopy(); 185 | 186 | /* BIG NUMBERS */ 187 | 188 | file_open(big); 189 | filecopy(); 190 | 191 | /* AUXILIARY FUNCTIONS */ 192 | 193 | file_open(lispzfn); 194 | filecopy(); 195 | 196 | /* LISP FUNCTIONS */ 197 | 198 | file_open(lispfn); 199 | filecopy1(); 200 | 201 | 202 | fclose(out_file); 203 | exit(0); 204 | } /* end of main */ 205 | 206 | -------------------------------------------------------------------------------- /crc.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "flags.l" 5 | #include "crfile.h" 6 | 7 | char ln[132], *buf, *obuf, fn[4], *lnp; 8 | FILE *in_file, *out_file; 9 | char nm[32], pnm[32], val[32], tp[30], compn[30], compc[30], compx[30], argv1[30]; 10 | int file_no, j, i1, i2, no; 11 | #if BITF 12 | int x1, x2, x3, x4, x5, x6; 13 | #else 14 | int x1; 15 | #endif 16 | 17 | void filecopy() 18 | { 19 | int c; 20 | 21 | while ((c = getc(in_file)) != EOF) 22 | putc(c, out_file); 23 | fprintf(out_file, "\n"); 24 | fclose(in_file); 25 | } 26 | 27 | void file_open(file_name) 28 | char *file_name; 29 | { 30 | in_file = fopen(file_name, "r"); 31 | if (in_file == NULL) { 32 | printf("\n File not found: "); 33 | printf("%s", file_name); 34 | printf("\n"); 35 | exit(1); 36 | } 37 | setvbuf(in_file, buf, _IOFBF, 16000); 38 | } 39 | 40 | void lispc() 41 | { 42 | strcpy(ln, "lispc"); 43 | strcat(ln, fn); 44 | strcat(ln, ".c"); 45 | out_file = fopen(ln, "w"); 46 | if (obuf != NULL) 47 | setvbuf(out_file, obuf, _IOFBF, 20000); 48 | 49 | /* FLAGS */ 50 | file_open(flags); 51 | filecopy(); 52 | 53 | /* TYPES AND MACROS */ 54 | file_open(types); 55 | filecopy(); 56 | file_open(type); 57 | filecopy(); 58 | 59 | fprintf(out_file, "extern PSEXP urwelt[];\n"); 60 | 61 | /* HEADER DECLARATIONS */ 62 | 63 | file_open(header); 64 | while (fgets(ln, 121, in_file) != NULL) { 65 | lnp = ln; 66 | if (ln[0] == '\n' || ln[0] == 'e' || ln[0] == '#') { 67 | fprintf(out_file, "%s", ln); 68 | continue; 69 | } 70 | if (ln[0] == ' ' || ln[0] == '\t' || ln[0] == '}') 71 | continue; 72 | while (1) { 73 | if (*lnp == ';') { 74 | *(++lnp) = 0; 75 | break; 76 | } 77 | if (*lnp == '=') { 78 | *lnp-- = 0; 79 | *lnp = ';'; 80 | break; 81 | } 82 | lnp++; 83 | } 84 | fprintf(out_file, "extern %s\n", ln); 85 | } 86 | fclose(in_file); 87 | 88 | 89 | /* SYSTEM IDENTIFIERS */ 90 | 91 | file_open(sysids); 92 | fprintf(out_file, "\n"); 93 | #if BITF 94 | while (fscanf(in_file, "%s%d%d%d%d%d%d%s%s", 95 | nm, &x1, &x2, &x3, &x4, &x5, &x6, pnm, val) != EOF) 96 | #else 97 | while (fscanf(in_file, "%s%d%s%s", nm, &x1, pnm, val) != EOF) 98 | #endif 99 | fprintf(out_file, "extern ID %s; \n", nm); 100 | fclose(in_file); 101 | 102 | /* CHARACTER IDENTIFIERS */ 103 | 104 | fprintf(out_file, "\nextern ID chrid[128];\n"); 105 | 106 | /* FUNCTION NAME IDENTIFIERS */ 107 | 108 | fprintf(out_file, "\nextern ID fname[];\n"); 109 | 110 | /* AUXILIARY FUNCTION declarations */ 111 | 112 | file_open(zfnames); 113 | fprintf(out_file, "\n"); 114 | while (fscanf(in_file, "%s%s", tp, nm) != EOF) 115 | fprintf(out_file, "%s %s();\n", tp, nm); 116 | fclose(in_file); 117 | 118 | 119 | /* FUNCTION DECLARATIONS */ 120 | 121 | strcpy(ln, compn); 122 | strcat(ln, fn); 123 | /* strcat(ln,"."); */ 124 | file_open(ln); 125 | fprintf(out_file, "\nvoid "); 126 | j = 0; 127 | while (fscanf(in_file, "%s%s%d%s", nm, pnm, &no, tp) != EOF) { 128 | if (j != 0) 129 | fprintf(out_file, ","); 130 | if (j % 6 == 0) 131 | fprintf(out_file, "\n "); 132 | strcat(pnm, "()"); 133 | fprintf(out_file, " %s", pnm); 134 | j++; 135 | } 136 | fclose(in_file); 137 | fprintf(out_file, ";\n"); 138 | strcpy(ln, compx); /* now externals */ 139 | strcat(ln, fn); 140 | /* strcat(ln,"."); */ 141 | file_open(ln); 142 | fprintf(out_file, "\nextern void\n"); 143 | filecopy(); 144 | 145 | /* COMPILED LISP FUNCTIONS */ 146 | 147 | strcpy(ln, compc); 148 | strcat(ln, fn); 149 | /* strcat(ln,"."); */ 150 | fprintf(out_file, "#include \"%s\"\n", ln); 151 | fclose(out_file); 152 | return; 153 | } 154 | 155 | 156 | /* main may have three optional arguments. arguments should be given in this 157 | order. 158 | arg 1) input file name base. 159 | arg 1) number of the first file. default first (1). 160 | arg 2) number of the last file. default all (100). */ 161 | 162 | int main(argc, argv) 163 | int argc; 164 | char *argv[]; 165 | { 166 | i1 = 1; 167 | i2 = 100; 168 | buf = (char *)malloc(16000); /* set larger buffers for IO operations */ 169 | obuf = (char *)malloc(20000); 170 | if (argc == 2) 171 | strcpy(argv1, argv[1]); 172 | else { 173 | fprintf(stderr, "Usage: crc [file]\n"); 174 | return -1; /* force user to use "comp" argument if desired */ 175 | } 176 | strcpy(compn, argv1); 177 | strcat(compn, "n"); 178 | strcpy(compx, argv1); 179 | strcat(compx, "x"); 180 | strcpy(compc, argv1); 181 | strcat(compc, "c"); 182 | if (argc >= 3) 183 | sscanf(argv[2], "%d", &i1); 184 | if (argc >= 4) 185 | sscanf(argv[3], "%d", &i2); 186 | 187 | for (file_no = i1 ; file_no <= i2 ; file_no++) { 188 | sprintf(fn, "%d", file_no); 189 | strcpy(ln, compn); 190 | strcat(ln, fn); 191 | /* strcat(ln,"."); */ 192 | in_file = fopen(ln, "r"); 193 | if (in_file == NULL) 194 | break; 195 | else 196 | fclose(in_file); 197 | lispc(); 198 | } 199 | exit(0); 200 | } /* end of main part */ 201 | 202 | -------------------------------------------------------------------------------- /crfile.h: -------------------------------------------------------------------------------- 1 | #define flags "flags.l" 2 | #define fnames "fnames.l" 3 | #define types "types.l" 4 | #define zfnames "zfnames.l" 5 | #define errors "errors.l" 6 | #define header "hd.l" 7 | #define yylex "yylex.l" 8 | #define lispfn "lisp-fn.l" 9 | #define lispzfn "lisp-zfn.l" 10 | #define type "type.l" 11 | #define big "big-n.l" 12 | 13 | #if BITF 14 | #define sysids "sysids.l" 15 | #else 16 | #define sysids "sysid.l" 17 | #endif 18 | -------------------------------------------------------------------------------- /cri.c: -------------------------------------------------------------------------------- 1 | /* creator of the LISP-INI */ 2 | #include 3 | #include 4 | #include 5 | 6 | #define outfile "LISP-INI" 7 | char comp[30], argv1[30], argv2[30], *buf, *obuf; 8 | FILE *in_file, *out_file; 9 | 10 | int i; 11 | 12 | 13 | void filecopy() 14 | { 15 | int c; 16 | 17 | while ((c = getc(in_file)) != EOF) 18 | putc(c, out_file); 19 | fprintf(out_file, "\n"); 20 | fclose(in_file); 21 | } 22 | 23 | void file_open(file_name) 24 | char *file_name; 25 | { 26 | in_file = fopen(file_name, "r"); 27 | if (in_file == NULL) { 28 | printf("\n File not found: "); 29 | printf("%s", file_name); 30 | printf("\n"); 31 | exit(1); 32 | } 33 | if (buf != NULL) 34 | setvbuf(in_file, buf, _IOFBF, 16000); 35 | } 36 | 37 | int main(argc, argv) 38 | int argc; 39 | char *argv[]; 40 | { 41 | buf = (char *)malloc(16000); 42 | obuf = (char *)malloc(20000); 43 | if ( argc >= 3) 44 | strcpy(argv2, argv[2]); 45 | else 46 | strcpy(argv2, outfile); 47 | out_file = fopen(argv2, "w"); 48 | if (obuf != NULL) 49 | setvbuf(out_file, obuf, _IOFBF, 20000); 50 | 51 | if (argc >= 2) 52 | strcpy(argv1, argv[1]); 53 | else { 54 | fprintf(stderr, "Usage: cri [file]\n"); 55 | return -1; /* force user to use "comp" argument if desired */ 56 | } 57 | strcpy(comp, argv1); 58 | strcat(comp, "u"); 59 | file_open(comp); 60 | filecopy(); 61 | 62 | strcpy(comp, argv1); 63 | strcat(comp, "e"); 64 | file_open(comp); 65 | filecopy(); 66 | fprintf(out_file, "nil\n"); 67 | fclose(out_file); 68 | exit(0); 69 | } 70 | -------------------------------------------------------------------------------- /errors.l: -------------------------------------------------------------------------------- 1 | % not % for % 2 | poorly formed atom in compress 3 | % is a nonlocal variable 4 | % can not be changed to fluid 5 | % can not be changed to global 6 | can not change t or nil 7 | % is not a known label 8 | illegal use of go to % 9 | illegal use of return 10 | % subscript is out of range 11 | a vector of size % cannot be allocated 12 | improper cond form as argument of cond 13 | % parameter to % is not a number 14 | attempt to divide by zero in % 15 | different length lists in pair 16 | % is an undefined function 17 | % cannot be evaluated by apply 18 | number of parameters do not match 19 | unbound % 20 | % improperly formed lambda expression 21 | % could not be closed 22 | % is an invalid line length 23 | % is not an option for open 24 | % could not be opened 25 | % could not be selected for input 26 | % could not be selected for output 27 | % is a poorly formed alist 28 | % is not id or string for % 29 | % is not single character id for % 30 | interrupt 31 | % is an invalid page length 32 | improper argument to select 33 | out of p-name space 34 | out of string space 35 | % has not been defined yet 36 | store jam 37 | % is not a valid argument for % 38 | lisp stack overflow 39 | alist overflow 40 | % is big for % 41 | can not redefine % 42 | integer overflow 43 | input buffer save table overflow (max 100 files can be open simultaneously) 44 | % is an invalid file handle 45 | poorly formed string 46 | % is not a valid argument list for % 47 | -------------------------------------------------------------------------------- /flags.l: -------------------------------------------------------------------------------- 1 | #define LINUX 1 /* Linux specific parts. Ver 7.1 */ 2 | #define SLOWSTACK 0 /*procedural stack manipulation*/ 3 | #define DSTACK 1 /*dynamic resizable stack*/ 4 | #define BITF 0 /*bit fields are used in ID space*/ 5 | #define TRACEABLE 1 /* controls some trace parts */ 6 | #define DEBUG 0 /* For indoor developement use only! */ 7 | -------------------------------------------------------------------------------- /fnames.l: -------------------------------------------------------------------------------- 1 | abs Abs 1 subr 2 | add1 Add1 1 subr 3 | alength Alength 1 subr 4 | and And 1 fsubr 5 | append Append 2 subr 6 | apply Apply 2 subr 7 | ascii Ascii 1 subr 8 | assoc Assoc 2 subr 9 | atom Atom 1 subr 10 | caaaar Caaaar 1 subr 11 | caaadr Caaadr 1 subr 12 | caaar Caaar 1 subr 13 | caadar Caadar 1 subr 14 | caaddr Caaddr 1 subr 15 | caadr Caadr 1 subr 16 | caar Caar 1 subr 17 | cadaar Cadaar 1 subr 18 | cadadr Cadadr 1 subr 19 | cadar Cadar 1 subr 20 | caddar Caddar 1 subr 21 | cadddr Cadddr 1 subr 22 | caddr Caddr 1 subr 23 | cadr Cadr 1 subr 24 | car Car 1 subr 25 | cdaaar Cdaaar 1 subr 26 | cdaadr Cdaadr 1 subr 27 | cdaar Cdaar 1 subr 28 | cdadar Cdadar 1 subr 29 | cdaddr Cdaddr 1 subr 30 | cdadr Cdadr 1 subr 31 | cdar Cdar 1 subr 32 | cddaar Cddaar 1 subr 33 | cddadr Cddadr 1 subr 34 | cddar Cddar 1 subr 35 | cdddar Cdddar 1 subr 36 | cddddr Cddddr 1 subr 37 | cdddr Cdddr 1 subr 38 | cddr Cddr 1 subr 39 | cdr Cdr 1 subr 40 | close Close1 1 subr 41 | cdif Cdif 2 subr 42 | cmod Cmod 1 subr 43 | cplus Cplus 2 subr 44 | crecip Crecip 1 subr 45 | ctimes Ctimes 2 subr 46 | setmod Setmod 1 subr 47 | codep Codep 1 subr 48 | compress Compress 1 subr 49 | cond Cond 1 fsubr 50 | cons Cons 2 subr 51 | constantp Constantp 1 subr 52 | copy Copy 1 subr 53 | de De 1 fsubr 54 | deflist Deflist 2 subr 55 | delete Delete 2 subr 56 | df Df 1 fsubr 57 | difference Difference 2 subr 58 | digit Digit 1 subr 59 | divide Divide 2 subr 60 | dm Dm 1 fsubr 61 | dump Dump 1 subr 62 | eject Eject 0 subr 63 | eq Eq 2 subr 64 | eqn Eqn 2 subr 65 | equal Equal 2 subr 66 | error Error 2 subr 67 | errorset Errorset 3 subr 68 | eval Eval 1 subr 69 | evlis Evlis 1 subr 70 | expand Expand 2 subr 71 | explode Explode 1 subr 72 | expt Expt 2 subr 73 | fix Fix 1 subr 74 | fixp Fixp 1 subr 75 | flag Flag 2 subr 76 | flagp Flagp 2 subr 77 | float Float 1 subr 78 | floatp Floatp 1 subr 79 | fluid Fluid 1 subr 80 | fluidp Fluidp 1 subr 81 | function Function 1 fsubr 82 | garbage Garbage 0 subr 83 | gensym Gensym 0 subr 84 | get Get 2 subr 85 | getprop Getprop 1 subr 86 | getd Getd 1 subr 87 | getv Getv 2 subr 88 | global Global 1 subr 89 | globalp Globalp 1 subr 90 | go Go 1 fsubr 91 | greaterp Greaterp 2 subr 92 | idp Idp 1 subr 93 | intern Intern 1 subr 94 | length Length 1 subr 95 | lessp Lessp 2 subr 96 | linelength Linelength 1 subr 97 | list List 1 fsubr 98 | list2 List2 2 subr 99 | list3 List3 3 subr 100 | list4 List4 4 subr 101 | list5 List5 5 subr 102 | liter Liter 1 subr 103 | load Load 1 subr 104 | logor2 Logor2 2 subr 105 | logand2 Logand2 2 subr 106 | logxor2 Logxor2 2 subr 107 | lposn Lposn 0 subr 108 | map Map 2 subr 109 | mapc Mapc 2 subr 110 | mapc2 Mapc2 2 subr 111 | mapcan Mapcan 2 subr 112 | mapcar Mapcar 2 subr 113 | mapcon Mapcon 2 subr 114 | maplist Maplist 2 subr 115 | max Max 1 fsubr 116 | max2 Max2 2 subr 117 | member Member 2 subr 118 | memq Memq 2 subr 119 | min Min 1 fsubr 120 | min2 Min2 2 subr 121 | minus Minus 1 subr 122 | minusp Minusp 1 subr 123 | mkvect Mkvect 1 subr 124 | nconc Nconc 2 subr 125 | ncons Ncons 1 subr 126 | not Not 1 subr 127 | null Null 1 subr 128 | numberp Numberp 1 subr 129 | oblist Oblist 0 subr 130 | open Open1 2 subr 131 | onep Onep 1 subr 132 | or Or 1 fsubr 133 | orderp Orderp 2 subr 134 | pagelength Pagelength 1 subr 135 | pair Pair 2 subr 136 | pairp Pairp 1 subr 137 | plus Plus 1 fsubr 138 | plus2 Plus2 2 subr 139 | posn Posn 0 subr 140 | prin1 Prin1 1 subr 141 | prin2 Prin2 1 subr 142 | princ Princ 1 subr 143 | print Print 1 subr 144 | prog Prog 1 fsubr 145 | prog2 Prog2 2 subr 146 | progn Progn 1 fsubr 147 | put Put 3 subr 148 | putd Putd 3 subr 149 | putv Putv 3 subr 150 | quit Quit 0 subr 151 | quote Quote 1 fsubr 152 | quotient Quotient 2 subr 153 | rds Rds 1 subr 154 | read Read1 0 subr 155 | readch Readch 0 subr 156 | remainder Remainder 2 subr 157 | remd Remd 1 subr 158 | remflag Remflag 2 subr 159 | remob Remob 1 subr 160 | remprop Remprop 2 subr 161 | return Return 1 subr 162 | reverse Reverse 1 subr 163 | reversip Reversip 1 subr 164 | rplaca Rplaca 2 subr 165 | rplacd Rplacd 2 subr 166 | sassoc Sassoc 3 subr 167 | select Select 1 fsubr 168 | set Set 2 subr 169 | setpchar Setpchar 1 subr 170 | setq Setq 1 fsubr 171 | signoff Signoff 0 subr 172 | signon Signon 0 subr 173 | standard-lisp Standardfzlisp 0 subr 174 | stringp Stringp 1 subr 175 | sub1 Sub1 1 subr 176 | sublis Sublis 2 subr 177 | subst Subst 3 subr 178 | system System1 1 subr 179 | terpri Terpri 0 subr 180 | time Time 0 subr 181 | times Times 1 fsubr 182 | times2 Times2 2 subr 183 | token Token 0 subr 184 | traceable Traceable 1 subr 185 | unfluid Unfluid 1 subr 186 | unlink Unlink1 1 subr 187 | upbv Upbv 1 subr 188 | vectorp Vectorp 1 subr 189 | wrs Wrs 1 subr 190 | xcons Xcons 2 subr 191 | zerop Zerop 1 subr 192 | -------------------------------------------------------------------------------- /hd.l: -------------------------------------------------------------------------------- 1 | FILE *inputf; 2 | FILE *outputf; 3 | 4 | char tx[TXSIZE]; 5 | char yytext[128]; 6 | 7 | int traceable = 0; /*trace apply */ 8 | unsigned currcol = 0; 9 | unsigned lineln = 72; 10 | unsigned currlin = 0; 11 | unsigned pageln = 0; 12 | unsigned delimflag; 13 | unsigned digitcnt = 0; /* # of digits of parsed integer. */ 14 | long *arit1; /* pointer to arith array. used by big arith */ 15 | long *arit2; /* routines */ 16 | unsigned arit1sz = 100; /* sizes of these arrays */ 17 | unsigned arit2sz = 100; 18 | unsigned gensymcounter = 0; 19 | unsigned gcpage; /*used in gc. collection T.Y. */ 20 | unsigned chrcount = 0; /*counts # of characters in p-name space */ 21 | unsigned strcount = 0; /*counts # of characters in string space */ 22 | unsigned atompgc; /*GC on atom's print name space*/ 23 | unsigned strgc; /*GC on string space*/ 24 | #if DSTACK 25 | int stacksize = STACKSIZE; /*local stack size*/ 26 | #endif 27 | unsigned ALISTLENGTH = 8192; /*alist stack length*/ 28 | unsigned PNSLENGTH = 24000; /*atom's print name space*/ 29 | unsigned STRLENGTH = 8500; /*string space length*/ 30 | 31 | unsigned maxpair = 1440; /*max empty work space if possible*/ 32 | unsigned maxpage = 5; /*max pages allocated without GC */ 33 | 34 | PAIR dummypair = { 35 | Tpair, NIL, NIL 36 | }; 37 | BIG dummybig = { 38 | Tbig, 0L, NIL 39 | }; 40 | PSTRING dummystrptr; 41 | 42 | INTEGER small_num[9] = { 43 | {Tinteger, -1L}, 44 | {Tinteger, 0L}, /* frequently used numbers TY*/ 45 | {Tinteger, 1L}, 46 | {Tinteger, 2L}, 47 | {Tinteger, 3L}, 48 | {Tinteger, 4L}, 49 | {Tinteger, 5L}, 50 | {Tinteger, 6L}, 51 | {Tinteger, 7L} 52 | }; 53 | 54 | ERRMSG forprog = { 55 | Terrmsg, 0, NIL 56 | }; 57 | 58 | PALISTENT alist; 59 | PALISTENT alisttop, zalisttop; 60 | PPAGE pages[NTYPES], cpages[NTYPES]; 61 | PPAGE freepages; 62 | 63 | unsigned sz[NTYPES] = { 64 | sizeof(PAIR), 65 | sizeof(ID), 66 | sizeof(STRING), 67 | sizeof(INTEGER), 68 | sizeof(BIG), 69 | sizeof(FLOATING), 70 | sizeof(VECTOR) 71 | }; 72 | 73 | unsigned gcfree[NTYPES]; 74 | unsigned npages; 75 | unsigned tnpages[NTYPES]; 76 | PCHAR pnmchp, strchp, startpns, startstr; 77 | 78 | #if DSTACK 79 | PPSEXP zstackp, zstackptr; 80 | #else 81 | PSEXP zstackp[STACKSIZE]; 82 | int zstackptr = -1; 83 | #endif 84 | 85 | #if SLOWSTACK 86 | #if DSTACK 87 | void kpops(); 88 | #endif 89 | void ksets(); 90 | void kloads(); 91 | #endif 92 | 93 | ERRORTRAP trap[30]; 94 | ERRORTRAP *curtrap = trap; 95 | char *curpos; 96 | PSEXP registers[16]; 97 | char *environment = NULL; 98 | 99 | -------------------------------------------------------------------------------- /lap.lsp: -------------------------------------------------------------------------------- 1 | (global 2 | '(registers alphabet framelocs labels grandlab labinuse urwelt 3 | urlength !*cegal atlas calledf calledfloc compf !*maxfnamelen 4 | genfncount!* genfname!*)) 5 | 6 | (setq registers (mkvect 15)) 7 | 8 | (setq alphabet 9 | (prog (!$dummy!$ i) 10 | (setq i 65) 11 | !$label 12 | (cond ((greaterp i 90) (return (reverse !$dummy!$)))) 13 | (setq !$dummy!$ 14 | (cons (cons (ascii (plus2 i 32)) (ascii i)) !$dummy!$)) 15 | (setq !$dummy!$ 16 | (cons (cons (ascii i) (ascii i)) !$dummy!$)) 17 | (setq i (add1 i)) 18 | (go !$label))) 19 | (prog (i) 20 | (setq i 1) 21 | !$label 22 | (cond ((greaterp i 15) (return nil))) 23 | (putv registers i (compress (append '(r e g) (explode i)))) 24 | (setq i (add1 i)) 25 | (go !$label)) 26 | 27 | (setq framelocs (mkvect 20)) 28 | 29 | (de storefunc (u v w) 30 | (progn 31 | (setq genfunction 32 | (cons (cons 'de (cons u (cdr w))) genfunction)) 33 | u)) 34 | (df output1 (!&x) 35 | (mapc !&x 36 | (function 37 | (lambda (xwx) 38 | (cond 39 | ((null xwx) (progn (terpri) (prin2 " "))) 40 | ((eq xwx t) (terpri)) 41 | (t (prin2 (eval xwx)))) ))) ) 42 | (de span (n) 43 | (prog (j i) 44 | (setq n (sub1 n)) 45 | (setq i 0) 46 | !$label 47 | (cond ((greaterp i n) (return (reversip j)))) 48 | (setq j (cons (minus i) j)) 49 | (setq i (add1 i)) 50 | (go !$label))) 51 | 52 | (de setdiff (y x) 53 | (mapcan 54 | y 55 | (function 56 | (lambda (e) (cond ((member e x) nil) (t (list e)))) ))) 57 | 58 | (de del (x l) 59 | (cond (l 60 | (cond ((equal x (car l)) (del x (cdr l))) 61 | (t (cons (car l) (del x (cdr l)))))) 62 | (t nil))) 63 | 64 | (de makelocal (i) 65 | (compress 66 | (append '(l o c a l !! !() (nconc (explode i) '(!! !))))) ) 67 | (prog (i) 68 | (setq i 0) 69 | !$label 70 | (cond ((greaterp i 20) (return nil))) 71 | (putv framelocs i (makelocal i)) 72 | (setq i (add1 i)) 73 | (go !$label)) 74 | (setq labels 75 | (prog (!$dummy!$ i) 76 | (setq i 1) 77 | !$label 78 | (cond ((greaterp i 90) (return (reverse !$dummy!$)))) 79 | (setq !$dummy!$ 80 | (cons (compress (append '(l a b) (explode i))) !$dummy!$)) 81 | (setq i (add1 i)) 82 | (go !$label))) 83 | (de locs (i) 84 | (progn 85 | (cond (atlas (setq i (cdr (assoc i atlas)))) ) 86 | (cond 87 | ((greaterp (abs i) 20) (makelocal (abs i))) 88 | (t (getv framelocs (abs i)))) )) 89 | (setq urwelt nil) 90 | (setq urlength -1) 91 | (de inurwelt (x) 92 | (prog (s) 93 | (setq s (member x urwelt)) 94 | (cond (s (return (sub1 (length s)))) ) 95 | (setq urwelt (cons x urwelt)) 96 | (return (setq urlength (add1 urlength)))) ) 97 | 98 | (de pexp (u) 99 | (progn 100 | (cond ((and (pairp u) (null (cdr u))) (setq u (car u)))) 101 | (cond 102 | ((or (null u) (equal u '(quote nil))) (prin2 "NIL")) 103 | ((or (eq u t) (equal u '(quote t))) (prin2 "T")) 104 | ((numberp u) 105 | (prin2 106 | (cond 107 | ((greaterp u 0) (getv registers u)) 108 | (t (locs u)))) ) 109 | ((memq (car u) '(fluid global)) 110 | (progn 111 | (prin2 "value(urwelt[") 112 | (prin2 (inurwelt (cadr u))) 113 | (prin2 "])"))) 114 | ((eq (car u) 'quote) 115 | (cond ((or (null (fixp (setq u (cadr u)))) 116 | (greaterp u 7) (lessp u -1)) 117 | (progn 118 | (prin2 "urwelt[") 119 | (prin2 (inurwelt u)) 120 | (prin2 "]")) ) 121 | (t 122 | (cond ((zerop u) (prin2 "Sexp(&ZERO)")) 123 | ((onep u) (prin2 "Sexp(&ONE)")) 124 | ((eqn u 2) (prin2 "Sexp(&TWO)")) 125 | ((eqn u 3) (prin2 "Sexp(&THREE)")) 126 | ((eqn u 4) (prin2 "Sexp(&FOUR)")) 127 | ((eqn u -1) (prin2 "Sexp(&M_ONE)")) 128 | ((eqn u 5) (prin2 "Sexp(&FIVE)")) 129 | ((eqn u 6) (prin2 "Sexp(&SIX)")) 130 | ((eqn u 7) (prin2 "Sexp(&SEVEN)")))) )) 131 | (t (progn 132 | (prin2 (car u)) 133 | (prin2 "(") 134 | (pexp (cadr u)) 135 | (prin2 ")")))) )) 136 | 137 | (setq !*maxfnamelen nil) 138 | 139 | (de ersinize (u) 140 | (cond 141 | ((and !*maxfnamelen 142 | (greaterp (length (explode u)) !*maxfnamelen)) 143 | (genfname u)) 144 | (t (progn 145 | (setq u 146 | (cond 147 | ((flagp u 'specialname) (nconc (explode u) '(1))) 148 | (t (killunlem (explode u)))) ) 149 | (cond ((memq (car u) '(!1 !2 !3 !4 !5 !6 !7 !8 !9 !0)) 150 | (compress (append '(!! !_) u))) 151 | (t 152 | (compress (cons (cdr (assoc (car u) alphabet)) (cdr u)))))) 153 | ))) 154 | 155 | (setq genfname!* nil) 156 | (setq genfncount!* 0) 157 | 158 | (de genfname (u) 159 | (prog (v) 160 | (setq v (assoc u genfname!*)) 161 | (cond (v (return (cdr v)))) 162 | (setq genfncount!* (add1 genfncount!*)) 163 | (setq v (compress (append '(G e n F u n) (explode genfncount!*)))) 164 | (setq genfname!* (cons (cons u v) genfname!*)) 165 | (return v) 166 | )) 167 | 168 | (de killunlem (u) 169 | (cond 170 | ((null u) nil) 171 | ((eq (car u) '!!) 172 | (progn 173 | (setq u (cdr u)) 174 | (append 175 | (cdr (assoc (car u) !*cegal)) 176 | (killunlem (cdr u)))) ) 177 | (t (cons (car u) (killunlem (cdr u)))) )) 178 | 179 | (setq !*cegal 180 | '((! S P) (!! X L) (!" D Q) (!# N B) (!$ D L) (!% P S) (!& A N) 181 | (!' S Q) (!( L P) (!) R P) (!* A S) (!+ P L) (!, C M) (!- M N) 182 | (!. D T) (!/ S L) (!: C L) (!; S C) (!< L T) (!= E Q) (!> G T) 183 | (!? Q S) (!@ A T) (![ L B) (!\ B S) (!] R B) (!^ U P) (!` B Q) 184 | (!_ U S) (!{ L C) (!| O R) (!} R C) (!~ T L) 185 | (!1 !1) (!2 !2) (!3 !3) (!4 !4) (!5 !5) (!6 !6) (!7 !7) (!8 !8) 186 | (!9 !9) (!0 !0) 187 | )) 188 | 189 | (flag '(open close write read system) 'specialname) 190 | 191 | (de last (u) 192 | (prog (x) 193 | (setq x u) 194 | l (cond ((null (cdr x)) (return (car x)))) 195 | (setq x (cdr x)) 196 | (go l) 197 | nil )) 198 | 199 | (setq grandlab labels) 200 | (setq labinuse nil) 201 | 202 | (de fetchlab (u) 203 | (mapc u 204 | (function 205 | (lambda (x) 206 | (cond 207 | ((eq (car x) '!*lbl) 208 | (rplacd x (list (newlab (cadr x)))) ))) ))) 209 | 210 | (de delrep (u) 211 | (cond ((null u) nil) 212 | ((member (car u) (cdr u)) (delrep (cdr u))) 213 | (t (cons (car u) (delrep (cdr u))))) ) 214 | 215 | (de compactify (u) 216 | (prog (r s n) 217 | (cond ((or (null (setq n (assoc '!*alloc u))) (zerop (cadr n)) ) 218 | (progn (setq atlas nil) (return nil)) )) 219 | (mapc u 220 | (function 221 | (lambda (e) 222 | (cond ((eq (car e) '!*freerstr) 223 | (setq s (nconc s 224 | (mapcar (cadr e) (function cadr)))) ))) )) 225 | (cond ((null s) (progn (setq atlas nil) (return nil)) )) 226 | (setq r (length s)) 227 | (cond ((eqn r 2) 228 | (cond ((eqn (car s) (cadr s)) (setq s (cdr s)))) ) 229 | ((greaterp r 2) (setq s (delrep s))) ) 230 | (mapc u 231 | (function 232 | (lambda (e) 233 | (cond ((and (eq (car e) '!*store) (member (caddr e) s)) 234 | (setq s (delete (caddr e) s))))))) 235 | (cond ((null s) (progn (setq atlas nil) (return nil)) )) 236 | (setq n (cadr n)) 237 | (setq r (difference n (length s))) 238 | (setq atlas 239 | (pair 240 | (setdiff (span n) s) 241 | (span r) )) 242 | (setq r (ncons r)) 243 | (rplacd (assoc '!*alloc u) r) 244 | (rplacd (assoc '!*dealloc u) r) 245 | )) 246 | 247 | (de newlab (u) 248 | (progn 249 | (setq labinuse (cons (cons u (car labels)) labinuse)) 250 | (setq labels (cdr labels)) 251 | (cdar labinuse))) 252 | (de initlab nil (progn (setq labels grandlab) (setq labinuse nil))) 253 | (de getlab (u) (cdr (assoc u labinuse))) 254 | (de lap (zaz) 255 | (progn 256 | (setq labels grandlab) 257 | (fetchlab zaz) 258 | (compactify zaz) 259 | (mapc zaz (function lap1)))) 260 | (de lap1 (uuu) 261 | (eval 262 | (cons (car uuu) 263 | (mapcar (cdr uuu) 264 | (function (lambda (xyx) 265 | (cond ((or (pairp xyx) (idp xyx)) (list 'quote xyx)) 266 | (t xyx)))) 267 | ))) ) 268 | (de !*entry (name type narg) 269 | (progn 270 | (terpri) 271 | (prin2 "void ") 272 | (prin2 (ersinize name)) 273 | (output1 "() /* ") 274 | (prin1 name) 275 | (output1 " */" t "{"))) 276 | 277 | (de !*alloc (n) 278 | (cond 279 | ((not (zerop n)) 280 | (progn (output1 nil "kalloc(") (prin2 n) (prin2 ");")))) ) 281 | (de !*dealloc (n) 282 | (cond 283 | ((not (zerop n)) 284 | (progn (output1 nil "kpop(") (prin2 n) (prin2 ");")))) ) 285 | (de !*jump (labl) 286 | (progn (output1 nil "goto ") (prin2 (getlab labl)) (prin2 ";"))) 287 | (de !*jumpnil (labl) 288 | (progn 289 | (output1 nil "if (null(reg1)) goto ") 290 | (prin2 (getlab labl)) 291 | (prin2 ";"))) 292 | (de !*jumpt (labl) 293 | (progn 294 | (output1 nil "if (!null(reg1)) goto ") 295 | (prin2 (getlab labl)) 296 | (prin2 ";"))) 297 | (de !*jumpe (labl exp) 298 | (progn 299 | (output1 nil "if (reg1 == ") 300 | (pexp exp) 301 | (prin2 ") goto ") 302 | (prin2 (getlab labl)) 303 | (prin2 ";"))) 304 | (de !*jumpn (labl exp) 305 | (progn 306 | (output1 nil "if (reg1 != ") 307 | (pexp exp) 308 | (prin2 ") goto ") 309 | (prin2 (getlab labl)) 310 | (prin2 ";"))) 311 | (de !*jumpc (labl reg name) 312 | (progn 313 | (output1 nil "if (") 314 | (prin2 name) 315 | (prin2 "(") 316 | (prin2 (getv registers reg)) 317 | (prin2 ")) goto ") 318 | (prin2 (getlab labl)) 319 | (prin2 ";"))) 320 | (de !*jumpnc (labl reg name) 321 | (progn 322 | (output1 nil "if (!") 323 | (prin2 name) 324 | (prin2 "(") 325 | (prin2 (getv registers reg)) 326 | (prin2 ")) goto ") 327 | (prin2 (getlab labl)) 328 | (prin2 ";"))) 329 | (de !*lbl (labl) (progn (terpri) (prin2 labl) (prin2 " : "))) 330 | (de !*store (nreg floc) 331 | (progn 332 | (output1 nil) 333 | (cond 334 | ((fixp floc) 335 | (progn 336 | (cond (atlas (setq floc (cdr (assoc floc atlas)))) ) 337 | (cond 338 | ((zerop floc) (prin2 "kset0(")) 339 | (t (progn 340 | (prin2 "kset(") 341 | (prin2 (abs floc)) 342 | (prin2 ",")))) 343 | (pexp nreg) 344 | (prin2 ");"))) 345 | (t (progn 346 | (pexp floc) 347 | (prin2 " = ") 348 | (pexp nreg) 349 | (prin2 ";")))) )) 350 | (de !*load (reg exp) 351 | (cond 352 | ((or (equal reg exp) (and (pairp exp) (equal reg (car exp)))) 353 | nil) 354 | (t (progn 355 | (output1 nil) 356 | (cond 357 | ((and (pairp exp) (null (cdr exp))) 358 | (setq exp (car exp)))) 359 | (cond 360 | ((and (numberp exp) (null (greaterp exp 0))) 361 | (progn 362 | (cond 363 | (atlas (setq exp (cdr (assoc exp atlas)))) ) 364 | (cond 365 | ((zerop exp) 366 | (progn 367 | (prin2 "kload0(") 368 | (pexp reg) 369 | (prin2 ");"))) 370 | (t (progn 371 | (prin2 "kload(") 372 | (pexp reg) 373 | (prin2 ",") 374 | (prin2 (abs exp)) 375 | (prin2 ");")))) )) 376 | (t (progn 377 | (pexp reg) 378 | (prin2 " = ") 379 | (pexp exp) 380 | (prin2 ";")))) ))) ) 381 | (de !*link (name type nargs) 382 | (progn 383 | (cond 384 | ((null (memq name calledfloc)) 385 | (setq calledfloc (cons name calledfloc)))) 386 | (output1 nil) 387 | (prin2 (ersinize name)) 388 | (prin2 "();") 389 | (output1 " /* ") 390 | (prin1 name) 391 | (output1 " */") 392 | (cond 393 | ((and (null (memq name compf)) (null (assoc name calledf))) 394 | (setq calledf (cons (list name type nargs) calledf)))) )) 395 | (de !*linke (name type nargs n) 396 | (progn 397 | (!*dealloc n) 398 | (!*link name type nargs) 399 | (output1 nil "return;"))) 400 | (de !*lambind (regs alst) 401 | (mapc 402 | regs 403 | (function 404 | (lambda (reg) 405 | (progn 406 | (output1 nil "zbind(urwelt[") 407 | (prin2 (inurwelt (caar alst))) 408 | (prin2 "],") 409 | (prin2 (getv registers reg)) 410 | (prin2 ");") 411 | (setq alst (cdr alst)))) ))) 412 | (de !*progbind (alst) 413 | (mapc 414 | alst 415 | (function 416 | (lambda (entry) 417 | (progn 418 | (output1 nil "zbind(urwelt[") 419 | (prin2 (inurwelt (caar alst))) 420 | (prin2 "],NIL);") 421 | (setq alst (cdr alst)))) ))) 422 | (de !*freerstr (alst) 423 | (progn 424 | (output1 nil "zunbind(") 425 | (prin2 (length alst)) 426 | (prin2 ");"))) 427 | (de !&expandus (fn1 fn2 exp status) 428 | (progn 429 | (setq exp (cdr exp)) 430 | (cond 431 | ((greaterp (length exp) 2) 432 | (!&comval 433 | (list fn2 (car exp) (cons fn1 (cdr exp))) 434 | status)) 435 | (t (!&call fn2 exp status)))) ) 436 | (de !&comtimes (exp status) (!&expandus 'times 'times2 exp status)) 437 | (de !&complus (exp status) (!&expandus 'plus 'plus2 exp status)) 438 | (de !&commax (exp status) (!&expandus 'max 'max2 exp status)) 439 | (de !&commin (exp status) (!&expandus 'min 'min2 exp status)) 440 | (put 'plus 'compfn '!&complus) 441 | (put 'times 'compfn '!&comtimes) 442 | (put 'max 'compfn '!&commax) 443 | (put 'min 'compfn '!&commin) 444 | (setq !*r2i t) 445 | (put 'car 'anyreg t) 446 | (put 'cdr 'anyreg t) 447 | (de comrpla (exp status) 448 | (prog (u v w) 449 | (setq w (car exp)) 450 | (setq exp (cdr exp)) 451 | (setq u (car exp)) 452 | (setq v (cadr exp)) 453 | (!&clrregs) 454 | (cond 455 | ((!&anyreg u (list v)) 456 | (cond 457 | ((!&anyreg v nil) 458 | (progn 459 | (setq u (!&locate u)) 460 | (setq v (!&locate v)))) 461 | (t (progn 462 | (!&comval v 1) 463 | (setq u (!&locate u)) 464 | (setq v (list 1)))) )) 465 | ((!&anyreg v nil) 466 | (progn 467 | (!&comval u 1) 468 | (setq u (list 1)) 469 | (setq v (!&locate v)))) 470 | (t (progn 471 | (setq u (!&comlis exp)) 472 | (setq u (!&locate (cadr u))) 473 | (setq v (list 1)))) ) 474 | (!&attach 475 | (list (cond ((eq w 'rplaca) '!*rplaca) (t '!*rplacd)) u v)) 476 | (!&attach (list '!*load 1 u)) 477 | (setq regs (cons (cons 1 nil) (cdr regs))) 478 | )) 479 | (put 'rplaca 'compfn 'comrpla) 480 | (put 'rplacd 'compfn 'comrpla) 481 | (de !*rplaca (u v) 482 | (progn (output1 nil "car(") (pexp u) (prin2 ") = ") (pexp v) 483 | (prin2 ";"))) 484 | (de !*rplacd (u v) 485 | (progn (output1 nil "cdr(") (pexp u) (prin2 ") = ") (pexp v) 486 | (prin2 ";"))) 487 | (put '!*jumpnc 'optfn '!*jumpncopt) 488 | (de !*jumpncopt (u) 489 | (cond 490 | ((eq (car (cdddar u)) 'atom) 491 | (rplaca u (list '!*jumpc (cadar u) (caddar u) 'pairp))) 492 | ((eq (car (cdddar u)) 'pairp) 493 | (rplaca u (list '!*jumpc (cadar u) (caddar u) 'atom))) 494 | (t nil))) 495 | 496 | (put '!*freerstr 'optfn '!*freerstropt) 497 | 498 | (de !*freerstropt (u) 499 | (cond ((and 500 | (eq (caadr u) '!*lambind) 501 | (equal (cadar u) (car (cddadr u))) ) 502 | (rplacw u (cddr u)) ) 503 | (t nil) ) ) 504 | 505 | (put 'pairp 'comtst '!&testfn) 506 | (put 'null 'comtst '!&testfn) 507 | (put 'atom 'comtst '!&testfn) 508 | (put 'idp 'comtst '!&testfn) 509 | (put 'stringp 'comtst '!&testfn) 510 | (put 'fixp 'comtst '!&testfn) 511 | (put 'floatp 'comtst '!&testfn) 512 | (put 'vectorp 'comtst '!&testfn) 513 | (put 'codep 'comtst '!&testfn) 514 | (put 'numberp 'comtst '!&testfn) 515 | (put 'constantp 'comtst '!&testfn) 516 | (put 'globalp 'comtst '!&testfn) 517 | (put 'fluidp 'comtst '!&testfn) 518 | (put 'functionp 'comtst '!&testfn) 519 | (flag 520 | '(add1 abs alength and append ascii atom close codep compress 521 | cond cons xcons expand nconc ncons constantp copy difference 522 | digit eject eq eqn eval evlis explode fix fixp float floatp 523 | fluid fluidp function get getv greaterp lessp garbage gensym 524 | getprop getd global globalp go idp intern length linelength 525 | list liter lposn max max2 min min2 minus mkvect not null 526 | numberp oblist or onep orderp pagelength pairp posn prin1 527 | prin2 princ print prog prog2 progn setpchar quit quote remflag 528 | remprop rplaca rplacd set rds read readch remd remob return 529 | reverse reversip select setq signoff signon stringp sub1 530 | system terpri token unfluid unlink upbv vectorp wrs zerop) 531 | 'onereg) 532 | (flag 533 | '(assoc delete difference divide equal error list2 plus plus2 534 | quotient expt flag flagp map mapc mapcan mapcar mapcon mapc2 535 | maplist member memq open load orderp pair sublis times times2 536 | remainder logor2 logand2 logxor2) 537 | 'tworeg) 538 | (setq compf 539 | '(abs add1 alength and append apply ascii assoc atom caaaar caaadr 540 | caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr 541 | caddr cadr car cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar 542 | cddadr cddar cdddar cddddr cdddr cddr cdr close cdif cmod cplus 543 | crecip ctimes setmod codep compress cond cons constantp copy 544 | de deflist delete df difference digit divide dm dump eject eq eqn 545 | equal error errorset eval evlis expand explode expt fix fixp flag 546 | flagp float floatp fluid fluidp function garbage gensym get getprop 547 | getd getv global globalp go greaterp idp intern length lessp linelength 548 | list list2 list3 list4 list5 liter load logor2 logand2 logxor2 549 | lposn map mapc mapc2 mapcan mapcar mapcon maplist max max2 member 550 | memq min min2 minus minusp mkvect nconc ncons not null numberp 551 | oblist open onep or orderp pagelength pair pairp plus plus2 posn 552 | prin1 prin2 princ print prog prog2 progn put putd putv quit quote 553 | quotient rds read readch remainder remd remflag remob remprop 554 | return reverse reversip rplaca rplacd sassoc select set setpchar 555 | setq signoff signon standard!-lisp stringp sub1 sublis subst 556 | system terpri time times times2 token traceable unfluid unlink 557 | upbv vectorp wrs xcons zerop )) 558 | 559 | (setq !*nolinke t) 560 | 561 | (de !&comcons1 (exp status) 562 | (prog (u v) 563 | (cond 564 | ((or (null (setq exp (cdr exp))) (null (cdr exp))) 565 | (lprie "mismatch of arguments")) 566 | ((equal (cadr exp) '(quote nil)) 567 | (return (!&call 'ncons (ncons (car exp)) status)))) 568 | (setq u (car exp)) 569 | (setq v (cadr exp)) 570 | (!&clrregs) 571 | (cond 572 | ((!&anyreg u (list v)) 573 | (cond 574 | ((!&anyreg v nil) 575 | (progn 576 | (setq u (!&locate u)) 577 | (setq v (!&locate v)))) 578 | (t (progn 579 | (!&comval v 1) 580 | (setq u (!&locate u)) 581 | (setq v (list 1)))) )) 582 | ((!&anyreg v nil) 583 | (progn 584 | (!&comval u 1) 585 | (setq u (list 1)) 586 | (setq v (!&locate v)))) 587 | (t (progn 588 | (setq u (!&comlis exp)) 589 | (setq u (!&locate (cadr u))) 590 | (setq v (list 1)))) ) 591 | (cond 592 | ((and (equal u '(1)) (equal v '(2))) 593 | (!&attach (list '!*link 'cons 'expr 2))) 594 | ((and (equal u '(2)) (equal v '(1))) 595 | (!&attach (list '!*link 'xcons 'expr 2))) 596 | ((equal u '(1)) (!&attach (list '!*zcons2 v))) 597 | ((equal v '(1)) (!&attach (list '!*zcons3 u))) 598 | (t (!&attach (list '!*zcons u v)))) 599 | (setq regs (cons (ncons 1) (cdr regs))) 600 | nil )) 601 | (de !*zcons (u v) 602 | (progn (output1 nil "zconsc(") (pexp u) (prin2 ",") (pexp v) 603 | (prin2 ");"))) 604 | (de !*zcons2 (v) 605 | (progn (output1 nil "zcons2c(") (pexp v) (prin2 ");"))) 606 | (de !*zcons3 (u) 607 | (progn (output1 nil "zcons3c(") (pexp u) (prin2 ");"))) 608 | (put 'cons 'compfn '!&comcons1) 609 | 610 | 611 | (global 612 | '(inchannel outchannel !&!&tncp !*traceable !*rdable compfloc 613 | codechannel evalchannel urwlchannel xrefchannel namechannel 614 | max!-comp!-size)) 615 | 616 | (de informuser (x) 617 | (prog (curchannel) 618 | (setq curchannel (wrs outchannel)) 619 | (prin2 x) 620 | (wrs curchannel))) 621 | 622 | (setq max!-comp!-size 26000) 623 | 624 | (de compilefile (infile outfile) 625 | (prog (sexpr name type body ncp nfiles argno xx) 626 | (setq !&!&tncp (sub1 (length compf))) 627 | (cond ((or (null outfile) (null infile)) 628 | (return "IO files should be defined!"))) 629 | (setq calledfloc nil) 630 | (setq body (explode outfile)) 631 | (setq ncp 0) 632 | (setq name (compress (append body '(c 1)))) 633 | (setq codechannel (open name 'output)) 634 | (output1 "Code files will be named :" name t) 635 | (setq name (compress (append body '(e)))) 636 | (setq evalchannel (open name 'output)) 637 | (output1 "Evaluate file will be named :" name t) 638 | (setq name (compress (append body '(u)))) 639 | (setq urwlchannel (open name 'output)) 640 | (output1 "Urwelt file will be named :" name t) 641 | (setq name (compress (append body '(n 1)))) 642 | (setq namechannel (open name 'output)) 643 | (output1 "Fn-names files will be named :" name t) 644 | (setq name (compress (append body '(x 1)))) 645 | (setq xrefchannel (open name 'output)) 646 | (output1 "Xref files will be named :" name t) 647 | (cond (!*traceable (rplacd (getd '!*exit) (cdr (getd '!*exit2)))) 648 | (t (rplacd (getd '!*exit) (cdr (getd '!*exit3)))) ) 649 | (setq !*nolinke !*traceable) 650 | (setq nfiles 2) 651 | (setq inchannel (open infile 'input)) 652 | (setq outchannel (wrs nil)) 653 | (wrs outchannel) 654 | loop1 (rds inchannel) 655 | loop (cond 656 | (genfunction 657 | (progn 658 | (setq sexpr (car genfunction)) 659 | (setq genfunction (cdr genfunction)))) 660 | (t (setq sexpr (read)))) 661 | (cond 662 | ((and (pairp sexpr) (memq (car sexpr) '(de df)) 663 | (null (flagp (cadr sexpr) 'nocomp))) 664 | (prog nil 665 | (setq name (cadr sexpr)) 666 | (wrs outchannel) 667 | (cond 668 | ((flagp name 'lose) 669 | (progn 670 | (output1 t "*** not compiled (Lose flaged) " name t) 671 | (return nil))) 672 | ((memq name compf) 673 | (progn 674 | (output1 675 | t "*** Already compiled function IGNORED -->" name t) 676 | (return nil)))) 677 | (output1 t "compiling " name " ") 678 | (cond (outchannel 679 | (progn (wrs nil) 680 | (output1 t "compiling " name t) 681 | (wrs outchannel)))) 682 | (cond 683 | ((setq xx (assoc name calledf)) 684 | (setq calledf (delete xx calledf)))) 685 | (setq compf (cons name compf)) 686 | (setq compfloc (cons name compfloc)) 687 | (setq !&!&tncp (add1 !&!&tncp)) 688 | (setq argno (length (caddr sexpr))) 689 | (setq type 690 | (cdr 691 | (assoc (car sexpr) '((de . expr) (df . fexpr)))) ) 692 | (cond ((eq type 'fexpr) (put name 'cfntype '(fexpr)))) 693 | (setq sexpr 694 | (!&comproc 695 | (list3 'lambda (caddr sexpr) (cadddr sexpr)) name)) 696 | (cond (!*traceable 697 | (progn 698 | (setq sexpr (cons (list3 '!*tracearg !&!&tncp argno) sexpr)) 699 | (nconc (last sexpr) (ncons !&!&tncp)))) 700 | (t (progn 701 | (cond ((eqcar (setq xx (last sexpr)) '!*linke) 702 | (nconc sexpr (ncons '(!*exit1)))) 703 | ((not (equal xx '(!*exit))) 704 | (nconc sexpr (ncons '(!*exit))))) 705 | (cond ((or !*rdable (flagp name 'rdable)) 706 | (setq sexpr 707 | (cons (list3 '!*redefine !&!&tncp argno) sexpr)) 708 | )) ))) 709 | (setq sexpr 710 | (cond 711 | ((eq type 'expr) 712 | (cons (list4 '!*entry name 'subr 1) sexpr)) 713 | ((eq type 'fexpr) 714 | (cons (list4 '!*entry name 'fsubr 1) sexpr)))) 715 | (cond (!*plap (progn (wrs outchannel) (print sexpr)))) 716 | (setq ncp (plus2 ncp (length sexpr))) 717 | (wrs codechannel) 718 | (lap sexpr) 719 | (priname name argno type) 720 | (cond 721 | ((greaterp ncp max!-comp!-size) 722 | (progn 723 | (wrs xrefchannel) 724 | (dumpxtrn) 725 | (wrs outchannel) 726 | (close codechannel) 727 | (close namechannel) 728 | (close xrefchannel) 729 | (setq name 730 | (compress 731 | (append 732 | body 733 | (append '(x) (explode nfiles)))) ) 734 | (setq xrefchannel (open name 'output)) 735 | (setq ncp 0) 736 | (setq name 737 | (compress 738 | (append 739 | body 740 | (append '(c) (explode nfiles)))) ) 741 | (setq codechannel (open name 'output)) 742 | (setq name 743 | (compress 744 | (append 745 | body 746 | (append '(n) (explode nfiles)))) ) 747 | (setq namechannel (open name 'output)) 748 | (setq nfiles (add1 nfiles)))) ) 749 | nil )) 750 | ((eqcar sexpr 'open) 751 | (progn 752 | (close inchannel) 753 | (setq inchannel (eval sexpr)) 754 | (go loop1))) 755 | ((eq sexpr 'end) (return (finalize))) 756 | ((eq sexpr !$eof!$) 757 | (progn (wrs nil) (rds nil) (terpri) 758 | (prin2 "enter file name string or 'end' >") 759 | (setq sexpr (read)) 760 | (close inchannel) 761 | (cond ((eq sexpr 'end) (return (finalize))) 762 | (t 763 | (progn 764 | (setq inchannel (open sexpr 'input)) 765 | (go loop1)) )))) 766 | (t (prog nil 767 | (cond 768 | ((and sexpr (pairp sexpr) (null (flagp (car sexpr) 'ignore))) 769 | (progn (wrs evalchannel) (printq sexpr) (wrs outchannel)))) 770 | (cond 771 | ((and sexpr 772 | (pairp sexpr) 773 | (or (flagp (car sexpr) 'eval) 774 | (flagp (car sexpr) 'ignore))) 775 | (eval sexpr))) 776 | nil) 777 | ) 778 | ) 779 | (go loop))) 780 | 781 | (de dumpxtrn nil 782 | (prog (n x y) 783 | (cond ((null calledfloc) (return nil))) 784 | loop1 (cond ((null (memq (setq y (car calledfloc)) compfloc)) 785 | (setq x (cons y x)))) 786 | (setq calledfloc (cdr calledfloc)) 787 | (cond (calledfloc (go loop1))) 788 | (setq compfloc nil) 789 | (cond ((null x) (return nil))) 790 | (setq n 0) 791 | loop (setq n (add1 n)) 792 | (cond ((eqn (remainder n 6) 0) (terpri))) 793 | (prin1 (ersinize (car x))) 794 | (setq x (cdr x)) 795 | (cond (x (progn (prin2 "(),") (go loop)))) 796 | (prin2 "();") )) 797 | 798 | (flag '(fluid global dm putd) 'eval) 799 | 800 | (de finalize nil 801 | (prog (type pname narg) 802 | loop (cond ((null calledf) (go endofit))) 803 | (wrs outchannel) 804 | (output1 t "called but not defined: " (car calledf) t) 805 | (setq !&!&tncp (add1 !&!&tncp)) 806 | (setq pname (car calledf)) 807 | (setq type (cadr pname)) 808 | (setq narg (caddr pname)) 809 | (setq pname (car pname)) 810 | (wrs codechannel) 811 | (!*entry pname type 1) 812 | (output1 " zundefined(" !&!&tncp "," narg "); }" ) 813 | (priname pname narg type) 814 | (setq calledf (cdr calledf)) 815 | (setq compfloc (cons pname compfloc)) 816 | (go loop) 817 | endofit 818 | (setpchar ">") 819 | (wrs urwlchannel) 820 | (print (add1 urlength)) 821 | (setq urwelt (reversip urwelt)) 822 | (mapc urwelt (function print)) 823 | (print nil) 824 | % (rds nil) 825 | (wrs xrefchannel) 826 | (dumpxtrn) 827 | (wrs outchannel) 828 | (close codechannel) 829 | (close evalchannel) 830 | (close urwlchannel) 831 | (close namechannel) 832 | (close xrefchannel) 833 | (return "compilation finished"))) 834 | 835 | (de spaces (n) 836 | (prog (i) 837 | (setq i 1) 838 | !$label 839 | (cond ((greaterp i n) (return nil))) 840 | (prin2 " ") 841 | (setq i (add1 i)) 842 | (go !$label))) 843 | 844 | (fluid '(!&u !&v)) 845 | (de !*tracearg (!&u !&v) 846 | (output1 t "#if TRACEABLE" 847 | nil "if(ztracearg(" !&u "," !&v ")) goto exit;" t "#endif") ) 848 | 849 | (de !*redefine (!&u !&v) 850 | (output1 t "#if TRACEABLE" 851 | nil "if(zredefined(" !&u "," !&v ")) return;" t "#endif") ) 852 | 853 | (de !*exit2 (!&u) (output1 t "#if TRACEABLE" t "exit:" nil "ztraceval(" !&u 854 | ");" t "#endif" t "return;" t "}" t) ) 855 | (de !*exit1 nil (output1 nil "}" t)) 856 | (de !*exit3 nil (output1 nil "return;" t "}" t)) 857 | (de !*exit nil (!*exit3)) %dummy routine. 858 | 859 | (de priname (nm n type) 860 | (prog (u v) 861 | (wrs namechannel) 862 | (prin2 nm) 863 | (setq v (length (del '!! (explode nm)))) 864 | (cond ((lessp v 21) 865 | (spaces (difference 21 v))) 866 | (t (spaces 1))) 867 | (setq v (length (explode (prin2 (ersinize nm))))) 868 | (cond ((lessp v 21) 869 | (spaces (difference 21 v) )) 870 | (t (spaces 1))) 871 | (cond 872 | ((eq type 'expr) 873 | (progn (prin2 n) (prin2 " subr"))) 874 | (t (prin2 "1 fsubr"))) 875 | (terpri) 876 | (wrs outchannel) )) 877 | 878 | (setq !*plap nil) 879 | 880 | (flag '(remove) 'specialname) 881 | 882 | (flag '(zerop reversip) 'lose) 883 | 884 | (de mkprog (u v) (cons 'prog (cons u v))) 885 | 886 | (de quotep1 (x) 887 | (and 888 | (eqcar x 'quote) 889 | (not (atom (cdr x))) 890 | (null (cddr x)))) 891 | 892 | 893 | (de prin1q (x) 894 | (cond 895 | ((atom x) (prin1 x)) 896 | ((quotep1 x) (progn (prin2 '!') (prin1q (cadr x)) ) ) 897 | (t (prog nil 898 | (prin2 '!( ) 899 | l1 (prin1q (car x)) 900 | (setq x (cdr x)) 901 | (cond ((pairp x) (progn (prin2 '! ) (go l1))) 902 | (x (progn (prin2 " . ") (prin1 x)))) 903 | (prin2 '!) ))))) 904 | 905 | (de printq (x) (progn (prin1q x) (terpri))) 906 | (output1 "compiler loaded." t "usage: (compilefile )" t) 907 | -------------------------------------------------------------------------------- /lisp-zfn.l: -------------------------------------------------------------------------------- 1 | char last_gc = 0; /*reason of last garbage collection*/ 2 | int trace1 = 0, trace2 = 0; /*trace level counters */ 3 | extern unsigned NOFPAIR; 4 | #define movmem(s, t, n) memcpy(t, s, n) /* in case of undefined movmem */ 5 | /* patch 1 */ 6 | #if DSTACK 7 | PPSEXP zstacktop; 8 | 9 | void kalloc(n) 10 | unsigned n; 11 | { 12 | zstackptr += n; /* zstackptr is pointer TY*/ 13 | if (zstackptr > zstacktop) { 14 | zstackptr -= n; /* For backtracking March 2009 TY */ 15 | zerror(37); 16 | } /*TY*/ 17 | } 18 | #else 19 | void kalloc(n) 20 | unsigned n; 21 | { 22 | zstackptr += n; /*zstackptr is integer TY*/ 23 | if (zstackptr > STACKSIZE - 1) 24 | zerror(37); /*TY*/ 25 | } 26 | #endif 27 | /*Slows down the lisp but generates (in general) */ 28 | #if SLOWSTACK /*smaller code.*/ 29 | #if DSTACK /*dynamic procedural stack manipulation TY*/ 30 | void ksets(n, x) 31 | unsigned n; 32 | PPSEXP x; 33 | { 34 | *(zstackptr - n) = *x; 35 | } 36 | 37 | void kloads(x, n) /* usage: kload(®1,0); */ 38 | unsigned n; 39 | PPSEXP x; 40 | { 41 | *x = *(zstackptr - n); 42 | } 43 | 44 | void kpops(n) 45 | unsigned n; 46 | { 47 | zstackptr -= n; 48 | } 49 | 50 | #else /*static procedural stack manipulation TY*/ 51 | void ksets(n, x) 52 | unsigned n; 53 | PPSEXP x; 54 | { 55 | zstackp[zstackptr - n] = *x; 56 | } 57 | 58 | void kloads(x, n) /* usage: kload(®1,0); */ 59 | unsigned n; 60 | PPSEXP x; 61 | { 62 | *x = zstackp[zstackptr - n]; 63 | } 64 | 65 | #endif 66 | #endif 67 | 68 | void zalist(x, y) 69 | PSEXP x, y; 70 | { 71 | #if BITF 72 | if (globalp(x) || functionp(x)) 73 | zerror(2, x); 74 | #else 75 | if (attribute(x) & 0x14) 76 | zerror(2, x); 77 | #endif 78 | if (alisttop > zalisttop) 79 | zerror(38); /*TY*/ 80 | alisttop->alistid = x; 81 | alisttop++->alistval = y; 82 | return; 83 | } 84 | 85 | void zbind(x, y) /*GU*/ /*This is new*/ 86 | PSEXP x, y; 87 | { 88 | zalist(x, value(x)); 89 | value(x) = y; 90 | } 91 | 92 | void zunbind(n) /*GU*/ /*This is also new*/ 93 | unsigned n; 94 | { 95 | while (n) { 96 | alisttop--; 97 | value(alisttop->alistid) = alisttop->alistval; 98 | n--; 99 | } 100 | } 101 | 102 | PSEXP zalloc(tp) 103 | int tp; /* changed char -> int Mar 2009 TY */ 104 | { 105 | int n = 0; 106 | PPAGE zgetpage(); 107 | PSEXP v; 108 | PPAGE p; 109 | 110 | while (1) { 111 | p = cpages[tp]; 112 | while (1) { 113 | if ((v = p->free) != NULL) { 114 | p->free = forwardadr(v); 115 | return (PSEXP)v; 116 | } 117 | if (p->nextpage == NULL) 118 | break; 119 | cpages[tp] = p = p->nextpage; 120 | } /*undefined expansion is suppressed below TY*/ 121 | switch (tp) { 122 | case Tpair: 123 | if ((tnpages[Tpair] < maxpage) || (gcfree[Tpair] < maxpair)) 124 | goto no_gc; 125 | break; 126 | case Tid: 127 | case Tinteger: 128 | case Tbig: 129 | case Tfloating: 130 | if ((last_gc == tp) || (gcfree[tp] < 3 * PAGESIZE / sz[tp])) 131 | goto no_gc; 132 | break; 133 | default: 134 | if (gcfree[tp] < PAGESIZE / sz[tp]) 135 | goto no_gc; 136 | break; 137 | } 138 | gc: 139 | if (n) 140 | zgarbage(Tforwardadr); /*compactifying GC. TY*/ 141 | else 142 | zgarbage(tp); 143 | if (gcfree[tp] != 0) 144 | continue; 145 | n++; 146 | no_gc: 147 | cpages[tp] = p->nextpage = zgetpage(tp); 148 | if (p->nextpage == NULL) { 149 | if (n < 2) 150 | goto gc; /* Mar 2009 TY */ 151 | else 152 | zerror(35); 153 | } /*not enough memory TY*/ 154 | } 155 | } 156 | 157 | PCHAR zcalloc(n) 158 | unsigned n; 159 | { 160 | PCHAR v; 161 | 162 | if ((chrcount + n) >= PNSLENGTH) { /* new in ver 3.3 ... GU */ 163 | zgarbage(Tpname); 164 | if ((chrcount + n) > PNSLENGTH) 165 | zerror(32); 166 | } 167 | chrcount += n; 168 | v = pnmchp; 169 | pnmchp += n; 170 | return v; 171 | } 172 | 173 | PCHAR zsalloc(n) /* Brand new in ver 3.3 ... GU */ 174 | unsigned n; 175 | /*Actual # of char's to build the STDLisp-string, e.g. for "ali" n=5 */ 176 | { 177 | PCHAR v; 178 | 179 | if ((strcount + n + STROFFSET2) >= STRLENGTH) { 180 | zgarbage(Tsname); 181 | if ((strcount + n + STROFFSET2) > STRLENGTH) 182 | zerror(33); 183 | } 184 | v = strchp; 185 | elmlength(v) = (char) n; /* here we store the length immediately */ 186 | n += STROFFSET2; 187 | /* [sizeof(Xlength) + sizeof(PSTRING):backpointer + 1 byte for:'\0'] */ 188 | strcount += n; 189 | strchp += n; 190 | return v; 191 | } 192 | 193 | void zedit(x) 194 | char *x; 195 | { 196 | if ((currcol += strlen(x)) > lineln) { 197 | putc('\n', outputf); 198 | currcol = strlen(x); 199 | } 200 | fprintf(outputf, "%s", x); 201 | return; 202 | } 203 | 204 | void pr_reg1(int col) 205 | { 206 | if (reg1 == NULL) 207 | fprintf(outputf, "NULL\n"); 208 | else { 209 | currcol = col; 210 | Prin1(); 211 | } 212 | Terpri(); 213 | } 214 | 215 | void dispargs(i) 216 | unsigned i; 217 | { 218 | unsigned j; 219 | PSEXP x; 220 | 221 | if (i == 0 || i > 16) 222 | return; 223 | x = reg1; 224 | for (j = 0 ; j < i ; j++) { 225 | reg1 = registers[j]; 226 | if (!null(reg1)) { 227 | fprintf(outputf, "reg%-2d : ", j + 1); 228 | pr_reg1(9); 229 | } 230 | } 231 | reg1 = x; 232 | } 233 | 234 | void dispstackarg() 235 | { 236 | unsigned j; 237 | PALISTENT u; 238 | PSEXP x; 239 | #if DSTACK 240 | PPSEXP v; 241 | #else 242 | int i; 243 | #endif 244 | 245 | fprintf(outputf, "\n"); 246 | x = reg1; 247 | dispargs(16); 248 | #if DSTACK 249 | v = zstackptr; 250 | for (j = 0 ; j <= 15 ; j++) { 251 | if (v < zstackp) 252 | goto l1; 253 | reg1 = *v; 254 | if (!null(reg1)) { 255 | fprintf(outputf, "STACK %4d-> ", j); 256 | pr_reg1(14); 257 | } 258 | v--; 259 | } 260 | #else 261 | i = zstackptr; 262 | for (j = 0 ; j <= 15 ; j++) { 263 | if (i < 0) 264 | goto l1; 265 | reg1 = zstackp[i]; 266 | if (!null(reg1)) { 267 | fprintf(outputf, "STACK %4d-> ", i); 268 | pr_reg1(14); 269 | } 270 | i--; 271 | } 272 | #endif 273 | l1: 274 | u = alisttop - 1; 275 | for (j = 0 ; j <= 15 ; j++) { 276 | if (u < alist) 277 | break; 278 | fprintf(outputf, "Alist top %2d-> ", j); 279 | currcol = 16; 280 | fprintf(outputf, "("); 281 | reg1 = u->alistid; 282 | Prin1(); 283 | reg1 = u->alistval; 284 | if (reg1 == NULL) 285 | fprintf(outputf, " . NULL"); 286 | else { 287 | zedit(" . "); 288 | Prin1(); 289 | } 290 | zedit(")"); 291 | Terpri(); 292 | u--; 293 | } 294 | reg1 = x; 295 | } /*end of stack argument dump procedure*/ 296 | 297 | void zerror (n, a1, a2, a3) 298 | unsigned n; 299 | PSEXP a1, a2, a3; 300 | { 301 | PSEXP a[3]; 302 | unsigned i = 0; 303 | char *m; 304 | PALISTENT als; 305 | PSEXP x; 306 | 307 | x = reg1; 308 | if (currcol) { 309 | putc('\n', outputf); 310 | cnewline; 311 | currcol = 0; 312 | } 313 | 314 | if (curtrap->msgprint) { 315 | a[0] = a1; 316 | a[1] = a2; 317 | a[2] = a3; 318 | m = emessages[n]; 319 | fprintf(outputf, "***** "); 320 | currcol = 6; 321 | while (*m) 322 | if (*m == '%') { 323 | reg1 = a[i++]; /*GU*/ 324 | Prin1(); /*GU*/ 325 | m++; 326 | } else { 327 | putc(*(m++), outputf); 328 | currcol++; 329 | } 330 | putc('\n', outputf); 331 | cnewline; 332 | currcol = 0; 333 | } 334 | reg1 = x; 335 | if (curtrap->backtrace) 336 | dispstackarg(); 337 | als = curtrap->curalist; 338 | while (als < alisttop) 339 | zpopalist(); 340 | zstackptr = curtrap->stacksave; 341 | longjmp(curtrap->errsave, n + 1); 342 | trace2 = trace1 = 0; 343 | return; 344 | } 345 | 346 | void zescape(u) 347 | PSEXP u; 348 | { 349 | char *x, *y; 350 | 351 | switch (type(u)) { 352 | case Tid: 353 | x = pname(u); 354 | y = tx; 355 | if (!isalpha(*x)) 356 | *y++ = '!'; 357 | *y++ = *x++; 358 | while (*x) { 359 | if (!isalpha(*x) && !isdigit(*x)) 360 | *y++ = '!'; 361 | *y++ = *x++; 362 | } 363 | *y = 0; 364 | return; 365 | case Tstring: 366 | x = strbody(u); 367 | y = tx; 368 | *y++ = '"'; 369 | while (*x) { 370 | if (*x == '"') 371 | *y++ = '"'; 372 | *y++ = *x++; 373 | } 374 | *y++ = '"'; 375 | *y = 0; 376 | return; 377 | case Tfloating: 378 | sprintf(tx, "%g", floval(u)); /* (%lg -> %g) Mar 2009 TY */ 379 | x = tx; 380 | while (*x) 381 | if (*x++ == '.') 382 | return; 383 | y = tx; 384 | while (*y) { 385 | if (*y == 'e') 386 | break; 387 | y++; 388 | } 389 | if (*y) { 390 | while (x >= y) { 391 | *(x + 1) = *x; 392 | x--; 393 | } 394 | *y = '.'; 395 | return; 396 | } 397 | *y++ = '.'; 398 | *y = 0; 399 | return; 400 | case Tinteger: 401 | sprintf(tx, "%ld", intval(u)); 402 | return; 403 | case Tfpointer: 404 | sprintf(tx, "#%lo#", (long) (Scode(u)->Xfnc)); 405 | return; 406 | } 407 | } 408 | 409 | 410 | PPAGE zgetpage(tp) /* modified to get allways from heap G.U.*/ 411 | unsigned tp; 412 | { 413 | unsigned n, s1; /*TY*/ 414 | char *x, *y, *z; 415 | PPAGE p; 416 | 417 | if ((p = freepages) != NULL) 418 | freepages = p->nextpage; 419 | else { 420 | p = (PPAGE) myalloc(sizeof(PAGE)); 421 | if (p == NULL) 422 | return NULL; 423 | npages++; 424 | } 425 | tnpages[tp]++; 426 | gcfree[tp] += (int) PAGESIZE / sz[tp]; 427 | x = NULL; 428 | s1 = sz[tp]; 429 | z = p->pagebd; 430 | for (n = 0 ; n < PAGESIZE ; n += s1) { 431 | y = z + n; 432 | if (tp == Tvector) 433 | usedvec(y) = 0; /*ver 5.2 TY*/ 434 | type(y) = tp; 435 | forwardadr(y) = (PSEXP) x; /* new link in GC collection 6.0 TY */ 436 | x = y; 437 | } 438 | p->free = (PSEXP) x; 439 | p->nextpage = NULL; 440 | return p; 441 | } 442 | 443 | void zinitpages() 444 | { 445 | PPAGE zgetpage(); 446 | unsigned n; 447 | 448 | npages = 0; 449 | freepages = NULL; 450 | for (n = 0 ; n < NTYPES ; n++) 451 | pages[n] = cpages[n] = zgetpage(n); 452 | } 453 | 454 | #define BUFSIZE 256 455 | void zurwelt() 456 | { 457 | FILE *fp; 458 | unsigned int i; 459 | char *x, buf[BUFSIZE]; /*TY*/ 460 | char u = 0; 461 | 462 | size_t j; 463 | /* if environment has been set by '-e' command line option take it; 464 | else set environment to "LISPINI"; 465 | GET the initialization file name from the environment; 466 | if the name obtained, try to open it; 467 | else try to open "LISP-INI"; 468 | if init file opened, it is the initialization file; 469 | else get the full path of running program and concatanate ".lispini" to it, 470 | and try open this file as an initialization file; 471 | if all fail, that means no initialization file. */ 472 | if (environment != NULL) { 473 | x = (PCHAR) getenv(environment); /*GU*/ 474 | if (!x) 475 | printf("Initialization environment %s not set\n", environment); 476 | } /*GU*/ 477 | else 478 | x = getenv("LISPINI"); /*GU*/ 479 | if (!x) 480 | x = "LISP-INI"; /*GU*/ 481 | fp = fopen(x, "r"); 482 | #if LINUX /*this part included in 7.1 May 2009 TY */ 483 | if (!fp) { 484 | j = readlink("/proc/self/exe", buf, (size_t) BUFSIZE); 485 | if (j != -1) { 486 | buf[j] = 0; 487 | x = strcat(buf, ".lispini"); 488 | fp = fopen(x, "r"); 489 | } 490 | } 491 | #endif 492 | if (!fp) { 493 | printf("No initialization file: %s or LISP-INI\n", x); 494 | if (ursize) 495 | zysuicide(6); 496 | else 497 | return; 498 | } 499 | inputf = fp; 500 | curtrap->msgprint = curtrap->backtrace = 1; 501 | curtrap->curalist = alisttop; 502 | curtrap->stacksave = zstackptr; 503 | initregs(); 504 | setjmp(curtrap->errsave); 505 | if (u) 506 | zysuicide(4); 507 | Read1(); 508 | if (!fixp(reg1)) 509 | zysuicide(2); 510 | if (ursize != (unsigned int) intval(reg1)) 511 | zysuicide(1); 512 | u = 1; 513 | if (ursize) { 514 | for (i = 0 ; i < ursize ; i++) { 515 | Read1(); 516 | urwelt[i] = reg1; 517 | } 518 | } 519 | curtrap = trap; 520 | setjmp(curtrap->errsave); 521 | if (u > 1) 522 | zysuicide(5); 523 | u++; 524 | Read1(); 525 | if (!null(reg1)) 526 | zysuicide(3); 527 | Read1(); 528 | while (!null(reg1)) { 529 | Eval(); 530 | Read1(); 531 | } 532 | fclose(fp); 533 | } 534 | 535 | void zysuicide(n) 536 | unsigned n; 537 | { 538 | switch (n) { 539 | case 1: 540 | printf("WRONG initialization file (LISP-INI) size!!\n"); 541 | break; 542 | case 2: 543 | printf("Initialization file must begin with size of initialization file (LISP-INI)!\n"); 544 | break; 545 | case 3: 546 | printf("nil must end initialization file (LISP-INI) !\n"); 547 | break; 548 | case 4: 549 | printf("WRONG initialization file (LISP-INI)!!\n"); 550 | break; 551 | case 5: 552 | printf("error in eval part of initialization file (LISP-INI)!!\n"); 553 | break; 554 | case 6: 555 | printf("Need to load initialization file (LISP-INI), but no initialization file exists!\n"); 556 | break; 557 | } 558 | exit(n); 559 | } 560 | 561 | PSEXP zinteger(x) 562 | long x; 563 | { 564 | PSEXP v; 565 | 566 | if ((x <= 7) && (x >= -1)) 567 | return Sexp(&small_num[(int)x + 1]); 568 | else { 569 | v = Sexp(zalloc(Tinteger)); 570 | intval(v) = x; 571 | return v; 572 | } 573 | } 574 | 575 | PSEXP zfloating(x) 576 | double x; 577 | { 578 | PSEXP v; /*TY*/ 579 | 580 | v = Sexp(zalloc(Tfloating)); 581 | floval(v) = x; 582 | return v; 583 | } 584 | 585 | PSEXP zcons(x, y) 586 | PSEXP x, y; 587 | { 588 | PPAIR v; 589 | v = Spair(zalloc(Tpair)); 590 | car(v) = x; 591 | cdr(v) = y; 592 | return Sexp(v); 593 | } 594 | 595 | PSEXP zcons1(x) 596 | PSEXP x; 597 | { 598 | PPAIR v; 599 | v = Spair(zalloc(Tpair)); 600 | car(v) = x; 601 | cdr(v) = NIL; 602 | return Sexp(v); 603 | } 604 | 605 | void zconsc(x, y) 606 | PSEXP x, y; 607 | { 608 | reg1 = Sexp(zalloc(Tpair)); 609 | car(reg1) = x; 610 | cdr(reg1) = y; 611 | } 612 | 613 | void zcons2c(x) 614 | PSEXP x; 615 | { 616 | PPAIR v; 617 | v = Spair(zalloc(Tpair)); 618 | car(v) = reg1; 619 | cdr(v) = x; 620 | reg1 = Sexp(v); 621 | } 622 | 623 | void zcons3c(x) 624 | PSEXP x; 625 | { 626 | PPAIR v; 627 | v = Spair(zalloc(Tpair)); 628 | car(v) = x; 629 | cdr(v) = reg1; 630 | reg1 = Sexp(v); 631 | } 632 | 633 | void zintern(n) 634 | unsigned n; /* n = 0 : set inoblistp to 0 */ 635 | { /* n = 1 : set inoblistp to 1 */ 636 | PCHAR cp; /* n = 2 : don't change inoblistp.. */ 637 | unsigned hs; /* .. if exist, otherwise create & set .. */ 638 | /* .. inoblistp to 1 */ 639 | 640 | cp = tx; 641 | hs = 0; 642 | while (*cp) 643 | hs += *cp++; 644 | hs = hs % 128; 645 | reg1 = Sexp(hashtab[hs]); 646 | while (reg1 != NULL) { 647 | if (strcmp(tx, pname(reg1)) == 0) { /* if found */ 648 | #if BITF 649 | if (n != 2) 650 | inoblistp(reg1) = n; 651 | #else 652 | if (n == 1) 653 | attribute(reg1) |= 0x02; 654 | #endif 655 | return; 656 | } 657 | reg1 = Sexp(hashlink(reg1)); 658 | } 659 | cp = zcalloc(strlen(tx) + 1); 660 | reg1 = zalloc(Tid); 661 | #if BITF 662 | globalp(reg1) = fluidp(reg1) = dclfluidp(reg1) = functionp(reg1) = 0; 663 | inheap(reg1) = 1; 664 | inoblistp(reg1) = !(!(n)); /* Trick n=1,2 :1 ; n=0 : 0 */ 665 | #else 666 | if (n == 0) 667 | attribute(reg1) = 0x20; /*it is in heap TY*/ 668 | else 669 | attribute(reg1) = 0x22; 670 | #endif 671 | hashlink(reg1) = hashtab[hs]; 672 | value(reg1) = NULL; 673 | proplist(reg1) = NIL; 674 | pname(reg1) = cp; 675 | strcpy(cp, tx); 676 | hashtab[hs] = Sid(reg1); 677 | } 678 | 679 | void zpopalist() 680 | { 681 | alisttop--; 682 | value(alisttop->alistid) = alisttop->alistval; 683 | } 684 | 685 | void zinterrupt() 686 | { 687 | /*curtrap = trap; return to current trap not very beginning TY*/ 688 | inputf = stdin; /* change the direction of input */ 689 | curtrap->backtrace = 0; /* do not backtrace */ 690 | zerror(29); 691 | } 692 | 693 | int ztracearg(u, v) /* traceable trace redefinition */ 694 | int u, v; /* 0 no no */ 695 | { 696 | PSEXP x, y; /* 1 no yes */ 697 | if (!traceable) 698 | return 0; /* >1 yes yes */ 699 | if (traceable == 1) 700 | goto exit; 701 | trace2++; 702 | if (traceable < trace2) 703 | goto exit; 704 | x = reg1; 705 | if (traceable == 0x7fff) 706 | goto okey; 707 | y = reg2; 708 | reg1 = Sexp(&fname[u]); 709 | reg2 = Sexp(&trace); 710 | Flagp(); 711 | reg2 = y; 712 | if (null(reg1)) { 713 | reg1 = x; 714 | goto exit; 715 | } 716 | okey: 717 | trace1++; 718 | zedit(">>Entering "); 719 | fprintf(outputf, "%3d", trace1); 720 | zedit(" : "); 721 | zedit(pname(Sexp(&fname[u]))); 722 | Terpri(); 723 | reg1 = x; 724 | if (v) 725 | dispargs(v); 726 | exit: 727 | return zredefined(u, v); 728 | } 729 | 730 | int zredefined(u, v) 731 | int u, v; 732 | { 733 | PSEXP y; 734 | 735 | y = value(&fname[u]); 736 | if (car(y) == Sexp(&expr)) { 737 | if (v > 5) 738 | zerror(40, Sexp(&fname[u])); 739 | switch (v) { 740 | case 0: 741 | break; 742 | case 1: 743 | Ncons(); 744 | break; 745 | case 2: 746 | List2(); 747 | break; 748 | case 3: 749 | List3(); 750 | break; 751 | case 4: 752 | List4(); 753 | break; 754 | case 5: 755 | List5(); 756 | break; 757 | } 758 | reg2 = reg1; 759 | reg1 = cdr(y); 760 | Apply(); 761 | return 1; 762 | } else if (car(y) == Sexp(&fexpr)) { 763 | if (v != 1) 764 | zerror(40, Sexp(&fname[u])); 765 | reg2 = reg1; 766 | reg1 = cdr(y); 767 | Apply(); 768 | return 1; 769 | } else 770 | return 0; 771 | } 772 | 773 | void zundefined(u, v) 774 | int u, v; 775 | { 776 | PSEXP x; 777 | x = value(&fname[u]); 778 | if (null(x)) 779 | return; 780 | if (car(x) != Sexp(&expr)) 781 | zerror(34, Sexp(&fname[u])); 782 | zredefined(u, v); 783 | } 784 | 785 | void ztraceval(u) 786 | int u; 787 | { 788 | PSEXP x, y; 789 | if (traceable < 2) 790 | return; 791 | trace2--; 792 | if (traceable <= trace2) 793 | return; 794 | x = reg1; 795 | if (traceable == 0x7fff) 796 | goto okey; 797 | y = reg2; 798 | reg1 = Sexp(&fname[u]); 799 | reg2 = Sexp(&trace); 800 | Flagp(); 801 | reg2 = y; 802 | if (null(reg1)) { 803 | reg1 = x; 804 | return; 805 | } 806 | okey: 807 | zedit(">>Leaving "); 808 | fprintf(outputf, "%3d", trace1); 809 | zedit(" : "); 810 | trace1--; 811 | zedit(pname(Sexp(&fname[u]))); 812 | Terpri(); 813 | reg1 = x; 814 | zedit("With value : "); 815 | Print(); 816 | } 817 | 818 | void errorreturn() 819 | { 820 | printf("\nNOT ENOUGH MEMORY\n"); 821 | exit(1); 822 | } 823 | 824 | /* Garbage Collection part */ 825 | 826 | void clear_forward(int tp) 827 | { 828 | unsigned s, i; /* clear forward type from partially filled page TY */ 829 | PPAGE pg; 830 | PCHAR p; 831 | 832 | pg = pages[tp]; 833 | if (pg->nextpage == NULL) 834 | return; /* is this the only page */ 835 | s = sz[tp]; 836 | i = PAGESIZE / s; 837 | while (pg != NULL) { /* find partially filled page */ 838 | if (pg->free != NULL) 839 | break; 840 | pg = pg->nextpage; 841 | } 842 | p = pg->pagebd; 843 | while (i--) { /* scan the page */ 844 | if (forwarded(p)) 845 | type(p) = tp; 846 | p += s; 847 | } /* take next ID */ 848 | } 849 | 850 | 851 | void zmark(x) 852 | PSEXP x; 853 | { 854 | PCHAR p; 855 | if (x == NULL) 856 | return; /*it is necessary TY*/ 857 | while (1) { 858 | switch (type(x)) { /* any cell marked or unmarked TY*/ 859 | case Tpair: 860 | putmark(x); 861 | zmark(car(x)); 862 | x = cdr(x); 863 | break; 864 | case Tbig: 865 | putmark(x); 866 | x = bigcdr(x); 867 | break; 868 | case Tid: 869 | putmark(x); 870 | if (atompgc && inheap(x)) { /*TY*/ 871 | p = pname(x); 872 | while (*p) 873 | p++; /*for p-name space GC. G.U. ver 3.3*/ 874 | *p = '\1'; 875 | } 876 | zmark(proplist(x)); 877 | zmark(value(x)); 878 | return; 879 | case Tvector: 880 | putmark(x); 881 | { 882 | unsigned n; 883 | for (n = 0 ; n <= upbv(x) ; n++) 884 | zmark(vectelt(x, n)); 885 | return; 886 | } 887 | case Tstring: /*for string space GC. ... ver 3.3*/ 888 | if (strgc) /*TY*/ 889 | *(strbody(x) + strlength(x)) = '\1'; /*That's exactly where \0 is*/ 890 | case Tinteger: 891 | case Tfloating: 892 | putmark(x); 893 | default: 894 | return; /* marked cells TY */ 895 | } 896 | } 897 | } 898 | 899 | int zcollect(p, tp, v) 900 | PPAGE p; 901 | int tp, v; 902 | { 903 | unsigned n, s1, m = 0; 904 | char *x, *y, *z; 905 | 906 | x = NULL; 907 | s1 = sz[tp]; 908 | z = p->pagebd; 909 | for (n = 0 ; n < PAGESIZE ; n += s1) { 910 | y = z + n; 911 | if (marked(y)) { 912 | clrmark(y); 913 | v = 0; 914 | } else { 915 | if ((tp == Tvector) && usedvec(y)) { 916 | free(vectelts(v)); /*ver 5.2 TY*/ 917 | usedvec(y) = 0; 918 | } 919 | forwardadr(y) = (PSEXP) x; /* ver 6.0 TY*/ 920 | x = y; 921 | m++; 922 | } 923 | } 924 | p->free = (PSEXP) x; 925 | if (v) { 926 | gcpage++; 927 | tnpages[tp]--; 928 | } else 929 | gcfree[tp] += m; 930 | return v; 931 | } 932 | 933 | void zcompactatom() /* new in ver. 3.3 ... GU */ 934 | { 935 | PCHAR s, f, cp; 936 | unsigned int n; 937 | unsigned hs; 938 | PID x; 939 | 940 | for (s = pnmchp ; s >= startpns ; s--) /* Blank out unreferenceds */ 941 | switch (*s) { 942 | case '\0': 943 | while (*s != '\1' && s >= startpns) 944 | *s-- = '\0'; 945 | case '\1': 946 | *s = '\0'; 947 | } 948 | 949 | f = startpns; /* Find first emptied position */ 950 | while (f < pnmchp) /* From now on f will point to empty pos.*/ 951 | if (!*f && !*++f) 952 | break; /* Empty pos. is at least two */ 953 | else 954 | f++; /* consecutive \0's */ 955 | 956 | s = f; /* Nonsense to start the search at startpns */ 957 | while (s < pnmchp) /* s seeks to find the first movable stuff */ 958 | if (!*s) 959 | s++; /* movables are NOT \0 , so skip over any \0 */ 960 | else { /* strlen returns # of non-\0 */ 961 | n = strlen(s) + 1; /* char`s in the string , so we add one */ 962 | hs = 0; /* Now we'll find which atom owns this pname */ 963 | cp = s; 964 | while (*cp) 965 | hs += *cp++; 966 | hs = hs % 128; /* That's our hash function */ 967 | x = hashtab[hs]; /* Fetch the hash bucket */ 968 | while (x != NULL) { /* Search the bucket for.. */ 969 | if (strcmp(s, pname(x)) == 0) { /* does the p-name match ? */ 970 | pname(x) = f; /* match found, so pname points to the new pos */ 971 | break; 972 | } /* Quit search */ 973 | x = hashlink(x); 974 | } /*No match;carry on with another atom in bucket*/ 975 | /* After all works we may throw away the IF below */ 976 | if (x == NULL) 977 | printf("\n %s cannot find father in p-name compaction!\n", s); 978 | movmem(s, f, n); /* Move all the stuff back to the empty pos */ 979 | s += n; /* Advance both pointers */ 980 | f += n; 981 | } 982 | pnmchp = f; /* The difference of pnmchp and f is the : */ 983 | /* "KISA GUNUN KARI" */ 984 | chrcount = pnmchp - startpns; 985 | } 986 | 987 | void zcompactstring() /* new in ver. 3.3 ... GU */ 988 | { 989 | char *s, *p; 990 | 991 | s = startstr; /* Start search of first-free-pos. at startstr */ 992 | while (s < strchp) { 993 | p = s + *s + STROFFSET; 994 | if (!*p) 995 | break; 996 | *p = '\0'; 997 | s = p + 1; 998 | } 999 | 1000 | p++; 1001 | while (p < strchp) { 1002 | if (!*(p + *p + STROFFSET)) { 1003 | p += *p + STROFFSET2; 1004 | continue; 1005 | } 1006 | movmem(p, s, (unsigned) (*p + STROFFSET)); 1007 | getelmfather(s)->Xstrelement = Sstrelement(s); 1008 | *(s + *s + STROFFSET) = '\0'; 1009 | p += *s + STROFFSET2; 1010 | s += *s + STROFFSET2; 1011 | } 1012 | strchp = s; 1013 | strcount = strchp - startstr; 1014 | } 1015 | 1016 | void zrelocate(tp) 1017 | int tp; 1018 | { 1019 | PCHAR fre, active; 1020 | PPAGE p, freepage, activepage; /* freepage points to page that contains */ 1021 | unsigned nf = 0, na; /* the element fre is pointing to */ 1022 | unsigned c, s; 1023 | 1024 | s = sz[tp]; /* get the size of that type: (tp) */ 1025 | c = PAGESIZE / s - 1; /* count of type (tp) that lives in a single page */ 1026 | activepage = NULL; 1027 | p = freepage = pages[tp];/* seeking for free pos. starts from head of link */ 1028 | while (p != NULL) { /* Form a back pointer chain over the free subfield */ 1029 | p->free = (PSEXP) activepage; 1030 | activepage = p; 1031 | p = p->nextpage; 1032 | } 1033 | /* here activepage contains ptr to last page */ 1034 | if (freepage == activepage) 1035 | return; /* no need to relocation TY */ 1036 | 1037 | fre = freepage->pagebd; /* first element in the first page */ 1038 | nf = 0; /* we count such that the first is 0 */ 1039 | 1040 | active = activepage->pagebd + PAGESIZE - s; /* last element in the last page */ 1041 | na = c; 1042 | 1043 | testfree: 1044 | /* searching down for the first empty element position */ 1045 | 1046 | if (!marked(fre)) 1047 | goto testactive; /* found an empty pos....HURRA */ 1048 | 1049 | seeknew: 1050 | /* carrying on the down search */ 1051 | 1052 | if (nf < c) { 1053 | fre += s; /* advance to following element position */ 1054 | nf++; 1055 | } else { /* that means we're at the end.. get next page */ 1056 | freepage->free = NULL; /*clear the back pointer. mark full page TY*/ 1057 | freepage = freepage->nextpage; 1058 | if (freepage == activepage) 1059 | return; /* end of relocation phase TY */ 1060 | fre = freepage->pagebd; /*pointing to first element in page */ 1061 | nf = 0; 1062 | } 1063 | goto testfree; /* is this position available ??? */ 1064 | 1065 | testactive: 1066 | /* searching up for the first marked element */ 1067 | 1068 | if (marked(active)) { /* found some thing to move up .. let's move it */ 1069 | /*no danger in using memcpy, source&target cannot overlap */ 1070 | memcpy(fre, active, s); 1071 | type(active) = Tforwardadr; /* We leave a forwarding address */ 1072 | forwardadr(active) = Sexp(fre); /* That is where we moved to */ 1073 | goto seeknew; 1074 | } /* try to find another candidate to move */ 1075 | 1076 | if (na) { 1077 | active -= s; /* go up in page to the previous element position */ 1078 | na--; 1079 | } else { /* that means we're at the start ..get next page to search */ 1080 | activepage = (PPAGE) (activepage->free); 1081 | if (freepage == activepage) 1082 | return; /* end of relocation phase TY */ 1083 | /* now we set active to point to the last element in page*/ 1084 | active = activepage->pagebd + PAGESIZE - s; 1085 | na = c; 1086 | } /* we were counting starting with 0 */ 1087 | 1088 | goto testactive; /* was this element marked ??? */ 1089 | } 1090 | 1091 | void zgarbage(tp) /* .... COMPACTIFYING GARBAGE COLLECTION .... *GU*/ 1092 | char tp; /* To turn-on compactification do (setq !*gctest 2) */ 1093 | { /* all the same until the end of the marking phase */ 1094 | PCHAR p; /*v 6.0 *GU*/ 1095 | unsigned s, k, m, r; /*v 6.0 *GU*/ 1096 | int info, n; 1097 | unsigned i, j; 1098 | PPSEXP x; 1099 | PALISTENT al; 1100 | PID ob, obl; 1101 | PPAGE pgx, pg; 1102 | PPAIR fn; 1103 | 1104 | /* dispstackarg(); GU */ 1105 | last_gc = tp; 1106 | i = chrcount; /*TY*/ 1107 | j = strcount; /*TY*/ 1108 | if (chrcount > PNSLENGTH - 512) 1109 | atompgc = 1; 1110 | else 1111 | atompgc = 0; /*TY*/ 1112 | if (strcount > STRLENGTH - 512) 1113 | strgc = 1; 1114 | else 1115 | strgc = 0; /*TY*/ 1116 | if (fixp(gcflag.Xvalue)) 1117 | info = (int)intval(gcflag.Xvalue); 1118 | else 1119 | info = gcflag.Xvalue != NIL || tp == Tuser; 1120 | if (info) 1121 | printf("\nGarbage collection for %d ...", tp); 1122 | for (n = 0 ; n < NTYPES ; n++) 1123 | gcfree[n] = 0; 1124 | gcpage = 0; 1125 | 1126 | /*******MARKING PHASE *******/ 1127 | 1128 | al = alisttop; 1129 | while (al-- != alist) { 1130 | zmark(al->alistid); 1131 | zmark(al->alistval); 1132 | } 1133 | /* let's mark from stack ... hahaha finally I DID IT */ 1134 | #if DSTACK 1135 | x = zstackp; /*dynamic stack garbage collection TY*/ 1136 | while (x <= zstackptr) 1137 | zmark(*x++); 1138 | #else 1139 | for (n = 0 ; n <= zstackptr ; n++) 1140 | zmark(zstackp[n]); 1141 | #endif 1142 | x = registers; /* mark registers */ 1143 | for (n = 0 ; n < 16 ; n++) 1144 | zmark(*x++); 1145 | zmark(bigcdr(&dummybig)); 1146 | /* Now mark from urwelt */ /*GU*/ 1147 | for (n = 0 ; n < ursize ; n++) 1148 | zmark(urwelt[n]); 1149 | for (n = 0 ; n < 128 ; n++) { 1150 | ob = hashtab[n]; /*new marking phase of oblist. ver. 5.2 TY */ 1151 | while (ob != NULL) { 1152 | if (value(ob) != NULL || !null(proplist(ob))) 1153 | zmark(Sexp(ob)); 1154 | ob = hashlink(ob); 1155 | } 1156 | } 1157 | 1158 | /******* SWEEP AND UNMARKING PHASE *******/ 1159 | 1160 | for (n = 0 ; n < 128 ; n++) { 1161 | if ((ob = hashtab[n]) == NULL) 1162 | continue; 1163 | l1: 1164 | if (inheap(ob)) { 1165 | if (!marked(ob)) { 1166 | ob = hashlink(ob); 1167 | goto l1; 1168 | } 1169 | } else if (ob) 1170 | clrmark(ob); /* if(ob) is new. 7.0 GU */ 1171 | hashtab[n] = ob; /*now different inheap 5.2 TY*/ 1172 | if (ob) 1173 | while ((obl = hashlink(ob)) != NULL) /* if(ob) is new 7.0 GU */ 1174 | if (!inheap(obl)) { 1175 | clrmark(obl); 1176 | ob = obl; 1177 | } else if (marked(obl)) 1178 | ob = obl; 1179 | else 1180 | hashlink(ob) = hashlink(obl); 1181 | } 1182 | fn = (PPAIR) fnvlpr; /*pointer to function value pairs*/ 1183 | for (n = 0 ; n < NOFPAIR ; n++) 1184 | clrmark(fn++); 1185 | for (n = 0 ; n <= 8 ; n++) 1186 | clrmark(&small_num[n]); 1187 | /*clear the mark in static part TY*/ 1188 | if (atompgc) { /*TY*/ 1189 | if (info) 1190 | printf("\nCompactify atom's p-name space ..."); /*TY*/ 1191 | zcompactatom(); 1192 | } 1193 | if (strgc) { /*TY*/ 1194 | if (info) 1195 | printf("\nCompactify string space ..."); /*TY*/ 1196 | zcompactstring(); 1197 | } 1198 | #if DEBUG 1199 | if (info > 2) 1200 | zdump("gc_dump1.lst"); 1201 | #endif 1202 | /* if(tppagebd; 1241 | r = m; 1242 | while (r--) { /* scan the page */ 1243 | if (marked(p)) { 1244 | if (forwarded(car(p))) 1245 | car(p) = Sexp(forwardadr(car(p))); 1246 | if (forwarded(cdr(p))) 1247 | cdr(p) = Sexp(forwardadr(cdr(p))); 1248 | } 1249 | p += s; 1250 | } /* take next PAIR */ 1251 | if (pg->free != NULL) 1252 | break; /* last marked page TY */ 1253 | pg = pg->nextpage; 1254 | } 1255 | 1256 | /* updating STRING space */ 1257 | pg = pages[Tstring]; 1258 | s = sz[Tstring]; 1259 | m = PAGESIZE / s; 1260 | while (pg != NULL) { /* scan the STRING space linked via nextpage field */ 1261 | p = pg->pagebd; 1262 | r = m; 1263 | while (r--) { /* scan the page */ 1264 | setfather(p); 1265 | p += s; 1266 | } /* take next STRING */ 1267 | if (pg->free != NULL) 1268 | break; /* last marked page TY */ 1269 | pg = pg->nextpage; 1270 | } 1271 | 1272 | /* updating BIGNUM space */ 1273 | pg = pages[Tbig]; 1274 | s = sz[Tbig]; 1275 | m = PAGESIZE / s; 1276 | while (pg != NULL) { /* scan the BIGNUM space linked via nextpage field */ 1277 | p = pg->pagebd; 1278 | r = m; 1279 | while (r--) { /* scan the page */ 1280 | if (marked(p) && forwarded(bigcdr(p))) 1281 | bigcdr(p) = Sexp(forwardadr(bigcdr(p))); 1282 | p += s; 1283 | } /* take next BIGNUM */ 1284 | if (pg->free != NULL) 1285 | break; /* last marked page TY */ 1286 | pg = pg->nextpage; 1287 | } 1288 | 1289 | /* updating VECTOR space */ 1290 | 1291 | pg = pages[Tvector]; 1292 | s = sz[Tvector]; 1293 | m = PAGESIZE / s; 1294 | while (pg != NULL) { /* scan the VECTOR space linked via nextpage field */ 1295 | p = pg->pagebd; 1296 | r = m; 1297 | while (r--) { /* scan the page */ 1298 | if (marked(p)) 1299 | for (k = 0 ; k <= upbv(p) ; k++) 1300 | if (forwarded(vectelt(p, k))) 1301 | vectelt(p, k) = Sexp(forwardadr(vectelt(p, k))); 1302 | p += s; 1303 | } /* take next VECTOR */ 1304 | if (pg->free != NULL) 1305 | break; /* last marked page TY */ 1306 | pg = pg->nextpage; 1307 | } 1308 | 1309 | /* updating ALIST */ 1310 | al = alisttop; 1311 | while (al-- != alist) { 1312 | if (forwarded(al->alistid)) 1313 | al->alistid = Sexp(forwardadr(al->alistid)); 1314 | if (forwarded(al->alistval)) 1315 | al->alistval = Sexp(forwardadr(al->alistval)); 1316 | } 1317 | 1318 | /* updating STACK */ 1319 | #if DSTACK 1320 | x = zstackp; /*dynamic stack garbage collection TY*/ 1321 | while (x <= zstackptr) { 1322 | if (forwarded(*x)) 1323 | *x = Sexp(forwardadr(*x)); 1324 | x++; 1325 | } 1326 | #else 1327 | for (n = 0 ; n <= zstackptr ; n++) 1328 | if (forwarded(zstackp[n])) 1329 | zstackp[n] = Sexp(forwardadr(zstackp[n])); 1330 | #endif 1331 | /* updating REGISTERS */ 1332 | x = registers; 1333 | for (n = 0 ; n < 16 ; n++) { 1334 | if (forwarded(*x)) 1335 | *x = Sexp(forwardadr(*x)); 1336 | x++; 1337 | } 1338 | 1339 | /* updating URWELT */ 1340 | for (n = 0 ; n < ursize ; n++) 1341 | if (forwarded(urwelt[n])) 1342 | urwelt[n] = Sexp(forwardadr(urwelt[n])); 1343 | #if DEBUG 1344 | if (info > 2) 1345 | zdump("gc_dump2.lst"); 1346 | #endif 1347 | for (n = 0 ; n < NTYPES ; n++) 1348 | clear_forward(n); 1349 | 1350 | /****** END OF UPDATING PHASE OF COMPACTIFICATION ******/ 1351 | 1352 | /******* UNMARKING *******/ 1353 | skip_relocation: 1354 | for (n = 0 ; n < NTYPES ; n++) { 1355 | pg = pages[n]; /* it cannot be NULL TY */ 1356 | while (pg != NULL) 1357 | if (zcollect(pg, n, pg->nextpage != NULL)) { 1358 | pgx = pg; 1359 | pg = pg->nextpage; 1360 | pgx->nextpage = freepages; 1361 | freepages = pgx; 1362 | } else 1363 | break; 1364 | pages[n] = pg; 1365 | while (pg->nextpage != NULL) 1366 | if (zcollect(pg->nextpage, n, 1)) { 1367 | pgx = pg->nextpage; 1368 | pg->nextpage = pg->nextpage->nextpage; 1369 | pgx->nextpage = freepages; 1370 | freepages = pgx; 1371 | } else 1372 | pg = pg->nextpage; 1373 | } 1374 | for (n = 0 ; n < NTYPES ; n++) { 1375 | if (pages[n] == NULL) 1376 | pages[n] = zgetpage(n); 1377 | cpages[n] = pages[n]; 1378 | } 1379 | #if DEBUG 1380 | if (info > 2) 1381 | zdump("gc_dump3.lst"); 1382 | #endif 1383 | /* dispstackarg(); GU */ 1384 | if (info) { 1385 | printf("\n %d free PAGES have been created out of %d \n", gcpage, npages); 1386 | printf("# of chr. in ATOM's P-name space (before - after) GC: (%5d - %5d)\n", 1387 | i, chrcount); 1388 | printf("# of chr. in STRING space: (%5d - %5d)\n", j, strcount); 1389 | #if DSTACK 1390 | n = zstackptr - zstackp; 1391 | printf("STACK contains %5d pointers\n", n); 1392 | #else 1393 | printf("STACK contains %5d pointers\n", zstackptr); 1394 | #endif 1395 | n = alisttop - alist; 1396 | printf("occupied ALIST entries %d\n", n); 1397 | printf(" created cells number\n"); 1398 | printf(" free cells per page of pages\n"); 1399 | printf("PAIR :%5d %4d %3d\n", 1400 | gcfree[Tpair], PAGESIZE / sz[Tpair], tnpages[Tpair]); 1401 | printf("ID :%5d %4d %3d\n", 1402 | gcfree[Tid], PAGESIZE / sz[Tid], tnpages[Tid]); 1403 | printf("STRING :%5d %4d %3d\n", 1404 | gcfree[Tstring], PAGESIZE / sz[Tstring], tnpages[Tstring]); 1405 | printf("INTEGER:%5d %4d %3d\n", 1406 | gcfree[Tinteger], PAGESIZE / sz[Tinteger], tnpages[Tinteger]); 1407 | printf("BIG :%5d %4d %3d\n", 1408 | gcfree[Tbig], PAGESIZE / sz[Tbig], tnpages[Tbig]); 1409 | printf("FLOAT :%5d %4d %3d\n", 1410 | gcfree[Tfloating], PAGESIZE / sz[Tfloating], tnpages[Tfloating]); 1411 | printf("VECTOR :%5d %4d %3d\n", 1412 | gcfree[Tvector], PAGESIZE / sz[Tvector], tnpages[Tvector]); 1413 | } 1414 | } /* end of garbage collection part */ 1415 | 1416 | #define LII (long unsigned) /*just for suppress warnings about type conversion. Mar 2009 TY */ 1417 | 1418 | void print_cell(FILE *df, PSEXP y) 1419 | { 1420 | if (y == NULL) { 1421 | fprintf(df, " NULL\n"); 1422 | return; 1423 | } 1424 | if (marked(y)) 1425 | fprintf(df, "*"); 1426 | else 1427 | fprintf(df, " "); 1428 | 1429 | switch (gtype(y)) { 1430 | case Tpair: 1431 | fprintf(df, "%08lx %02x %08lx %08lx\n", LII y, Tpair, LII car(y), LII cdr(y)); 1432 | return; 1433 | case Tid: 1434 | #if BITF 1435 | fprintf(df, "%08lx %02x %08lx %08lx %08lx %08lx", 1436 | LII y, Tid, LII hashlink(y), LII value(y), LII proplist(y), LII pname(y)); 1437 | #else 1438 | fprintf(df, "%08lx %02x %02x %08lx %08lx %08lx %08lx", 1439 | LII y, Tid, 0x00ff & attribute(y), LII hashlink(y), LII value(y), 1440 | LII proplist(y), LII pname(y)); 1441 | #endif 1442 | if (strlen(pname(y)) < 15) 1443 | fprintf(df, " %s\n", pname(y)); 1444 | else 1445 | fprintf(df, "\n"); 1446 | return; 1447 | case Tstring: 1448 | fprintf(df, "%08lx %02x %08lx\n", LII y, Tstring, LII Sstr(y)); 1449 | return; 1450 | case Tinteger: 1451 | fprintf(df, "%08lx %02x %12ld\n", LII y, Tinteger, intval(y)); 1452 | return; 1453 | case Tbig: 1454 | fprintf(df, "%08lx %02x %12ld %08lx\n", 1455 | LII y, Tbig, bigval(y), LII bigcdr(y)); 1456 | return; 1457 | case Tfloating: 1458 | fprintf(df, "%08lx %02x %20.14f\n", LII y, Tfloating, floval(y)); 1459 | return; 1460 | case Tvector: 1461 | fprintf(df, "%08lx %02x %5d %08lx\n", LII y, Tvector, upbv(y), LII vectelts(y)); 1462 | return; 1463 | case Tforwardadr: 1464 | fprintf(df, "%08lx %02x %08lx\n", LII y, Tforwardadr, LII forwardadr(y)); 1465 | return; 1466 | default: 1467 | fprintf(df, "Unknown type: %02x %08lx\n", 0x00ff & type(y), LII y); 1468 | } 1469 | } 1470 | #undef LII 1471 | 1472 | #if DEBUG 1473 | 1474 | void zdump(fn) 1475 | char *fn; 1476 | { 1477 | FILE *dumpf; 1478 | unsigned i, n, s1; 1479 | PCHAR z, y; 1480 | PPAGE pg; 1481 | PALISTENT al; 1482 | PPSEXP x; 1483 | 1484 | dumpf = fopen(fn, "w"); 1485 | pg = pages[Tpair]; 1486 | i = 1; 1487 | s1 = sz[Tpair]; 1488 | while (pg != NULL) { 1489 | fprintf(dumpf, "\nPAIR SPACE: page %d pointer %08lx\n", i, pg); 1490 | fprintf(dumpf, " free pair: %08lx\n", (pg->free)); 1491 | fprintf(dumpf, " x type(x) car(x) cdr(x)\n\n"); 1492 | z = pg->pagebd; 1493 | for (n = 0 ; n < PAGESIZE ; n += s1) { 1494 | y = z + n; 1495 | print_cell(dumpf, y); 1496 | } 1497 | i++; 1498 | pg = pg->nextpage; 1499 | } 1500 | pg = pages[Tid]; 1501 | i = 1; 1502 | s1 = sz[Tid]; 1503 | while (pg != NULL) { 1504 | fprintf(dumpf, "\nID SPACE: page %d pointer %08lx\n", i, pg); 1505 | fprintf(dumpf, " free id: %08lx\n", (pg->free)); 1506 | fprintf(dumpf, " IDP type attr hashlink value prop pnamep pname\n\n"); 1507 | z = pg->pagebd; 1508 | for (n = 0 ; n < PAGESIZE ; n += s1) { 1509 | y = z + n; 1510 | print_cell(dumpf, y); 1511 | } 1512 | i++; 1513 | pg = pg->nextpage; 1514 | } 1515 | pg = pages[Tstring]; 1516 | i = 1; 1517 | s1 = sz[Tstring]; 1518 | while (pg != NULL) { 1519 | fprintf(dumpf, "\nString SPACE: page %d pointer %08lx\n", i, pg); 1520 | fprintf(dumpf, " free id: %08lx\n", (pg->free)); 1521 | fprintf(dumpf, " Str Ptr type string body pointer\n\n"); 1522 | z = pg->pagebd; 1523 | for (n = 0 ; n < PAGESIZE ; n += s1) { 1524 | y = z + n; 1525 | print_cell(dumpf, y); 1526 | } 1527 | i++; 1528 | pg = pg->nextpage; 1529 | } 1530 | pg = pages[Tinteger]; 1531 | i = 1; 1532 | s1 = sz[Tinteger]; 1533 | while (pg != NULL) { 1534 | fprintf(dumpf, "\nInteger SPACE: page %d pointer %08lx\n", i, pg); 1535 | fprintf(dumpf, " free int: %08lx\n", (pg->free)); 1536 | fprintf(dumpf, " x type(x) value of int x\n\n"); 1537 | z = pg->pagebd; 1538 | for (n = 0 ; n < PAGESIZE ; n += s1) { 1539 | y = z + n; 1540 | print_cell(dumpf, y); 1541 | } 1542 | i++; 1543 | pg = pg->nextpage; 1544 | } 1545 | pg = pages[Tbig]; 1546 | i = 1; 1547 | s1 = sz[Tbig]; 1548 | while (pg != NULL) { 1549 | fprintf(dumpf, "\nBig Integer SPACE: page %d pointer %08lx\n", i, pg); 1550 | fprintf(dumpf, " free big int: %08lx\n", (pg->free)); 1551 | fprintf(dumpf, " x type(x) value_of_int(x) cdr(x) \n\n"); 1552 | z = pg->pagebd; 1553 | for (n = 0 ; n < PAGESIZE ; n += s1) { 1554 | y = z + n; 1555 | print_cell(dumpf, y); 1556 | } 1557 | i++; 1558 | pg = pg->nextpage; 1559 | } 1560 | pg = pages[Tfloating]; 1561 | i = 1; 1562 | s1 = sz[Tfloating]; 1563 | while (pg != NULL) { 1564 | fprintf(dumpf, "\nFloat SPACE: page %d pointer %08lx\n", i, pg); 1565 | fprintf(dumpf, " free id: %08lx\n", (pg->free)); 1566 | fprintf(dumpf, " Flt Ptr type floating value\n\n"); 1567 | z = pg->pagebd; 1568 | for (n = 0 ; n < PAGESIZE ; n += s1) { 1569 | y = z + n; 1570 | print_cell(dumpf, y); 1571 | } 1572 | i++; 1573 | pg = pg->nextpage; 1574 | } 1575 | pg = pages[Tvector]; 1576 | i = 1; 1577 | s1 = sz[Tvector]; 1578 | while (pg != NULL) { 1579 | fprintf(dumpf, "\nVector SPACE: page %d pointer %08lx\n", i, pg); 1580 | fprintf(dumpf, " free id: %08lx\n", (pg->free)); 1581 | fprintf(dumpf, "Vector Ptr type upbv pointer\n\n"); 1582 | z = pg->pagebd; 1583 | for (n = 0 ; n < PAGESIZE ; n += s1) { 1584 | y = z + n; 1585 | print_cell(dumpf, y); 1586 | } 1587 | i++; 1588 | pg = pg->nextpage; 1589 | } 1590 | al = alisttop; 1591 | fprintf(dumpf, "\n Alist space identifiers\n"); 1592 | fprintf(dumpf, " IDP type attribute hashlink value prop pnamep pname\n\n"); 1593 | while (al-- != alist) 1594 | print_cell(dumpf, al->alistid); 1595 | 1596 | fprintf(dumpf, "\n STACK\n"); 1597 | #if DSTACK 1598 | x = zstackp; /*dynamic stack garbage collection TY*/ 1599 | while (x <= zstackptr) 1600 | print_cell(dumpf, *x++); 1601 | #else 1602 | for (n = 0 ; n <= zstackptr ; n++) 1603 | print_cell(dumpf, zstackp[n]); 1604 | #endif 1605 | fprintf(dumpf, "\n REGISTERS\n"); 1606 | x = registers; 1607 | for (n = 0 ; n < 16 ; n++) 1608 | print_cell(dumpf, *x++); 1609 | 1610 | fprintf(dumpf, "\n HASHLIST\n"); 1611 | for (n = 0 ; n < 128 ; n++) 1612 | print_cell(dumpf, hashtab[n]); 1613 | 1614 | if (ursize) { 1615 | fprintf(dumpf, "\n URWELT\n"); 1616 | for (n = 0 ; n < ursize ; n++) 1617 | print_cell(dumpf, urwelt[n]); 1618 | } 1619 | fclose(dumpf); 1620 | } 1621 | 1622 | #endif 1623 | 1624 | void initregs() 1625 | { 1626 | int n; 1627 | PPSEXP x; 1628 | 1629 | trace2 = trace1 = 0; 1630 | x = registers; 1631 | for (n = 0 ; n < 16 ; n++) 1632 | *x++ = NIL; 1633 | } 1634 | 1635 | int main(int argc, char *argv[] ) 1636 | { 1637 | unsigned n; 1638 | 1639 | for (n = 1 ; n < argc ; n++) { 1640 | if ((*argv[n]++) == '-') { 1641 | *argv[n] = toupper(*argv[n]); 1642 | if ((*argv[n]) == 'E') { 1643 | argv[n]++; /* skip over the 'E' */ 1644 | if (!*argv[n]) 1645 | n++; /* so, user gave one blank */ 1646 | environment = (char *) malloc(strlen(argv[n] + 1)); 1647 | strcpy(environment, argv[n]); 1648 | continue; 1649 | } 1650 | sscanf((argv[n] + 1), "%u", &gcpage); /*converts string to integer, %d -> %u Mar 2009 TY */ 1651 | switch (*argv[n]) { 1652 | #if DSTACK 1653 | case 'S': 1654 | stacksize = gcpage; 1655 | break; /*DYNAMIC STACK*/ 1656 | #endif 1657 | case 'A': 1658 | ALISTLENGTH = gcpage; 1659 | break; 1660 | case 'P': 1661 | PNSLENGTH = gcpage; 1662 | break; 1663 | case 'T': 1664 | STRLENGTH = gcpage; 1665 | break; 1666 | case 'M': 1667 | maxpair = gcpage; 1668 | break; 1669 | case 'G': 1670 | maxpage = gcpage; 1671 | break; 1672 | } 1673 | } 1674 | } 1675 | #if DSTACK 1676 | zstackp = (PPSEXP) calloc(stacksize, sizeof(PSEXP)); 1677 | if (zstackp == NULL) 1678 | errorreturn(); /*clearence of stack is necessary TY*/ 1679 | zstackptr = zstackp - 1; 1680 | zstacktop = zstackp + stacksize - 1; 1681 | #else 1682 | for (n = 0 ; n < STACKSIZE ; n++) 1683 | zstackp[n] = NULL; 1684 | #endif 1685 | alist = (PALISTENT) myalloc(ALISTLENGTH * sizeof(ALISTENT)); 1686 | if (alist == NULL) 1687 | errorreturn(); 1688 | alisttop = alist; 1689 | zalisttop = alist + ALISTLENGTH - 1; 1690 | pnmchp = (PCHAR) myalloc(PNSLENGTH); 1691 | if (pnmchp == NULL) 1692 | errorreturn(); 1693 | startpns = pnmchp; 1694 | strchp = (PCHAR) myalloc(STRLENGTH); 1695 | if (strchp == NULL) 1696 | errorreturn(); 1697 | startstr = strchp; 1698 | arit1 = (long *)myalloc(arit1sz * sizeof(long)); /* now allocate big arith arrays. */ 1699 | if (arit1 == NULL) 1700 | errorreturn(); 1701 | arit2 = (long *)myalloc(arit1sz * sizeof(long)); 1702 | if (arit2 == NULL) 1703 | errorreturn(); 1704 | for (n = 0 ; n < NTYPES ; n++) 1705 | gcfree[n] = 0; 1706 | if (maxpair == 1440) /* initial value of maxpair is 1440 */ 1707 | maxpair = 5 * PAGESIZE / sz[Tpair]; 1708 | for (n = 0 ; n < INPUTSAVETABLESIZE ; n++) 1709 | input_buf_save_table[n].file = NULL; 1710 | zinitpages(); 1711 | initregs(); 1712 | inputf = stdin; 1713 | outputf = stdout; 1714 | yytext[0] = 0; 1715 | curpos = ""; 1716 | endpos = &input[INPUTBUFLEN - 1]; /* 7.1 TY */ 1717 | zysignonoff(1); 1718 | zurwelt(); 1719 | Standardfzlisp(); 1720 | exit(0); 1721 | } 1722 | -------------------------------------------------------------------------------- /manual/Makefile: -------------------------------------------------------------------------------- 1 | 2 | all: sl.pdf lispman.pdf 3 | 4 | sl.pdf : sl.tex sl.bib sl.bbl 5 | latex sl 6 | latex sl 7 | latex sl 8 | dvipdfm sl 9 | 10 | lispman.pdf : lispman.tex 11 | latex lispman 12 | latex lispman 13 | latex lispman 14 | dvipdfm lispman 15 | 16 | clean : 17 | rm -f *.aux *.dvi *.log *.toc *~ *.bak 18 | 19 | realclean : clean 20 | rm -f *.pdf 21 | 22 | -------------------------------------------------------------------------------- /manual/lispman.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/blakemcbride/PSL/f489ea67801d04d44cc65d63365d187cdd58dbe9/manual/lispman.pdf -------------------------------------------------------------------------------- /manual/reduce.sty: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 | % The REDUCE Style option File --- LaTeX version. % 3 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 4 | % 5 | % The document should start with: 6 | % \documentstyle[11pt,reduce,makeidx]{...} 7 | % 8 | % This style adds the following commands: 9 | % \COMPATNOTE{...} For compatibility notes. 10 | % \f{...} Sets function name is \tt. 11 | % \k{...} Sets BNF keyword bold. 12 | % \REDUCE REDUCE when needed as a word. 13 | % \RLISP RLISP when needed as a word. 14 | % \s{...} Sets BNF sentential form \em in <...> 15 | % \meta An alternative for BNF italics in <...> 16 | % \ttindex{...} Puts index entry in \tt font. 17 | % 18 | % 19 | % 20 | % Basic religion about REDUCE documentation. No paragraph indentation, 21 | % bigger skip between lines, ragged bottom, and not as much vertical 22 | % space. 23 | %% RmS: setup of size dependent parameters. 11pt is assumed, so let's force it. 24 | 25 | \typeout{Document style option `reduce' -- released 28 Jul 1998.} 26 | 27 | % **************************************** 28 | % * FONTS * 29 | % **************************************** 30 | % 31 | 32 | \lineskip 1pt % \lineskip is 1pt for all font sizes. 33 | \normallineskip 1pt 34 | \def\baselinestretch{1} 35 | 36 | % Each size-changing command \SIZE executes the command 37 | % \@setsize\SIZE{BASELINESKIP}\FONTSIZE\@FONTSIZE 38 | % where: 39 | % BASELINESKIP = Normal value of \baselineskip for that size. (Actual 40 | % value will be \baselinestretch * BASELINESKIP.) 41 | % 42 | % \FONTSIZE = Name of font-size command. The currently available 43 | % (preloaded) font sizes are: \vpt (5pt), \vipt (6pt), 44 | % \viipt (etc.), \viiipt, \ixpt, \xpt, \xipt, \xiipt, 45 | % \xivpt, \xviipt, \xxpt, \xxvpt. 46 | % \@FONTSIZE = The same as the font-size command except with an 47 | % '@' in front---e.g., if \FONTSIZE = \xivpt then 48 | % \@FONTSIZE = \@xivpt. 49 | % 50 | % For reasons of efficiency that needn't concern the designer, 51 | % the document style defines \@normalsize instead of \normalsize. This 52 | % is done only for \normalsize, not for any other size-changing 53 | % commands. 54 | 55 | \def\@normalsize{\@setsize\normalsize{13.6pt}\xipt\@xipt 56 | \abovedisplayskip .5\baselineskip 57 | \belowdisplayskip \abovedisplayskip 58 | \abovedisplayshortskip \z@ plus3\p@ 59 | \belowdisplayshortskip 6.5\p@ plus3.5\p@ minus3\p@ 60 | \let\@listi\@listI} % Setting of \@listi added 9 Jun 87 61 | 62 | \def\small{\@setsize\small{12pt}\xpt\@xpt 63 | \abovedisplayskip .5\baselineskip 64 | \belowdisplayskip \abovedisplayskip 65 | \abovedisplayshortskip \z@ plus3\p@ 66 | \belowdisplayshortskip 6\p@ plus3\p@ minus3\p@ 67 | \def\@listi{\leftmargin\leftmargini %% Added 22 Dec 87 68 | \topsep \z@\parsep 3\p@ plus2\p@ minus\p@ 69 | \itemsep .5\baselineskip}} 70 | 71 | \def\footnotesize{\@setsize\footnotesize{11pt}\ixpt\@ixpt 72 | \abovedisplayskip .5\baselineskip 73 | \belowdisplayskip \abovedisplayskip 74 | \abovedisplayshortskip \z@ plus\p@ 75 | \belowdisplayshortskip 4\p@ plus2\p@ minus2\p@ 76 | \def\@listi{\leftmargin\leftmargini %% Added 22 Dec 87 77 | \topsep \z@ \parsep 2\p@ plus\p@ minus\p@ 78 | \itemsep .5\baselineskip}} 79 | 80 | \def\scriptsize{\@setsize\scriptsize{9.5pt}\viiipt\@viiipt} 81 | \def\tiny{\@setsize\tiny{7pt}\vipt\@vipt} 82 | \def\large{\@setsize\large{14pt}\xiipt\@xiipt} 83 | \def\Large{\@setsize\Large{18pt}\xivpt\@xivpt} 84 | \def\LARGE{\@setsize\LARGE{22pt}\xviipt\@xviipt} 85 | \def\huge{\@setsize\huge{25pt}\xxpt\@xxpt} 86 | \def\Huge{\@setsize\Huge{30pt}\xxvpt\@xxvpt} 87 | 88 | \normalsize % Choose the normalsize font. 89 | 90 | 91 | % **************************************** 92 | % * PAGE LAYOUT * 93 | % **************************************** 94 | % 95 | % All margin dimensions measured from a point one inch from top and side 96 | % of page. 97 | 98 | % SIDE MARGINS: 99 | \if@twoside % Values for two-sided printing: 100 | \oddsidemargin 36pt % Left margin on odd-numbered pages. 101 | \evensidemargin 74pt % Left margin on even-numbered pages. 102 | \marginparwidth 100pt % Width of marginal notes. 103 | \else % Values for one-sided printing: 104 | \oddsidemargin 54pt % Note that \oddsidemargin = \evensidemargin 105 | \evensidemargin 54pt 106 | \marginparwidth 83pt 107 | \fi 108 | \marginparsep 10pt % Horizontal space between outer margin and 109 | % marginal note 110 | 111 | 112 | % VERTICAL SPACING: 113 | % Top of page: 114 | \topmargin 27pt % Nominal distance from top of page to top 115 | % of box containing running head. 116 | \headheight 12pt % Height of box containing running head. 117 | \headsep 25pt % Space between running head and text. 118 | % \topskip = 10pt % '\baselineskip' for first line of page. 119 | % Bottom of page: 120 | \footskip 30pt % Distance from baseline of box containing 121 | % foot to baseline of last line of text. 122 | 123 | % DIMENSION OF TEXT: 124 | % 24 Jun 86: changed to explicitly compute \textheight to avoid 125 | % roundoff. The value of the multiplier was calculated as the floor of 126 | % the old \textheight minus \topskip, divided by \baselineskip for 127 | % \normalsize. The old value of \textheight was 530.4pt. 128 | % \textheight is the height of text (including footnotes and figures, 129 | % excluding running head and foot). 130 | 131 | \textheight = 38\baselineskip 132 | \advance\textheight by \topskip 133 | \textwidth 360pt % Width of text line. 134 | % For two-column mode: 135 | \columnsep 10pt % Space between columns 136 | \columnseprule 0pt % Width of rule between columns. 137 | 138 | % A \raggedbottom command causes 'ragged bottom' pages: pages set to 139 | % natural height instead of being stretched to exactly \textheight. 140 | 141 | % FOOTNOTES: 142 | 143 | \footnotesep 7.7pt % Height of strut placed at the beginning of every 144 | % footnote = height of normal \footnotesize strut, 145 | % so no extra space between footnotes. 146 | 147 | \skip\footins 10pt plus 4pt minus 2pt % Space between last line of text 148 | % and top of first footnote. 149 | 150 | % FLOATS: (a float is something like a figure or table) 151 | % 152 | % FOR FLOATS ON A TEXT PAGE: 153 | % 154 | % ONE-COLUMN MODE OR SINGLE-COLUMN FLOATS IN TWO-COLUMN MODE: 155 | \floatsep 12pt plus 2pt minus 2pt % Space between adjacent floats 156 | % moved to top or bottom of 157 | % text page. 158 | \textfloatsep 20pt plus 2pt minus 4pt % Space between main text and 159 | % floats at top or bottom of 160 | % page. 161 | \intextsep 12pt plus 2pt minus 2pt % Space between in-text figures 162 | % and text. 163 | % In LaTeX2e, \@maxsep no longer exists 164 | \@ifundefined{@maxsep}{}% 165 | {\setlength{\@maxsep}{20pt}} % The maximum of \floatsep, 166 | % \textfloatsep and \intextsep 167 | % (minus the stretch and 168 | % shrink). 169 | % TWO-COLUMN FLOATS IN TWO-COLUMN MODE: 170 | \dblfloatsep 12pt plus 2pt minus 2pt % Same as \floatsep for 171 | % double-column figures in 172 | % two-column mode. 173 | \dbltextfloatsep 20pt plus 2pt minus 4pt % \textfloatsep for 174 | % double-column floats. 175 | % In LaTeX2e, \@dblmaxsep no longer exists 176 | \@ifundefined{@dblmaxsep}{}% 177 | {\setlength{\@dblmaxsep}{20pt}} % The maximum of \dblfloatsep 178 | % and \dbltexfloatsep. 179 | 180 | % FOR FLOATS ON A SEPARATE FLOAT PAGE OR COLUMN: 181 | % ONE-COLUMN MODE OR SINGLE-COLUMN FLOATS IN TWO-COLUMN MODE: 182 | \@fptop 0pt plus 1fil % Stretch at top of float page/column. (Must 183 | % be 0pt plus ...) 184 | \@fpsep 8pt plus 2fil % Space between floats on float page/column. 185 | \@fpbot 0pt plus 1fil % Stretch at bottom of float page/column. (Must 186 | % be 0pt plus ... ) 187 | 188 | % DOUBLE-COLUMN FLOATS IN TWO-COLUMN MODE. 189 | \@dblfptop 0pt plus 1fil % Stretch at top of float page. (Must be 0pt 190 | % plus ...) 191 | \@dblfpsep 8pt plus 2fil % Space between floats on float page. 192 | \@dblfpbot 0pt plus 1fil % Stretch at bottom of float page. (Must be 193 | % 0pt plus ... ) 194 | % MARGINAL NOTES: 195 | % 196 | \marginparpush 5pt % Minimum vertical separation between two 197 | % marginal notes. 198 | 199 | 200 | % **************************************** 201 | % * PARAGRAPHING * 202 | % **************************************** 203 | % 204 | \parskip 6pt plus 1pt %% RmS % Extra vertical space between 205 | % paragraphs. 206 | \parindent 0pt %% RmS % Width of paragraph indentation. 207 | \topsep 0pt %% RmS % Extra vertical space, in addition 208 | % to \parskip, added above and below 209 | % list and paragraphing environments. 210 | \partopsep 0pt %% RmS % Extra vertical space, in addition 211 | % to \parskip and \topsep, added when 212 | % user leaves blank line before 213 | % environment. 214 | \itemsep \topsep %% RmS % Extra vertical space, in addition 215 | % to \parskip, added between list 216 | % items. 217 | % See \@listI for values of \topsep and \itemsep 218 | 219 | % The following page-breaking penalties are defined 220 | 221 | \@lowpenalty 51 % Produced by \nopagebreak[1] or \nolinebreak[1] 222 | \@medpenalty 151 % Produced by \nopagebreak[2] or \nolinebreak[2] 223 | \@highpenalty 301 % Produced by \nopagebreak[3] or \nolinebreak[3] 224 | 225 | \@beginparpenalty -\@lowpenalty % Before a list or paragraph 226 | % environment. 227 | \@endparpenalty -\@lowpenalty % After a list or paragraph 228 | % environment. 229 | \@itempenalty -\@lowpenalty % Between list items. 230 | 231 | % \clubpenalty % 'Club line' at bottom of page. 232 | % \widowpenalty % 'Widow line' at top of page. 233 | % \displaywidowpenalty % Math display widow line. 234 | % \predisplaypenalty % Breaking before a math display. 235 | % \postdisplaypenalty % Breaking after a math display. 236 | % \interlinepenalty % Breaking at a line within a paragraph. 237 | % \brokenpenalty % Breaking after a hyphenated line. 238 | 239 | 240 | % **************************************** 241 | % * SECTIONS * 242 | % **************************************** 243 | % 244 | 245 | % \@startsection {NAME}{LEVEL}{INDENT}{BEFORESKIP}{AFTERSKIP}{STYLE} 246 | % optional * [ALTHEADING]{HEADING} 247 | % Generic command to start a section. 248 | % NAME : e.g., 'subsection' 249 | % LEVEL : a number, denoting depth of section -- i.e., 250 | % section=1, subsection = 2, etc. A section number will 251 | % be printed if and only if LEVEL < or = the value of 252 | % the secnumdepth counter. 253 | % INDENT : Indentation of heading from left margin 254 | % BEFORESKIP : Absolute value = skip to leave above the heading. 255 | % If negative, then paragraph indent of text following 256 | % heading is suppressed. 257 | % AFTERSKIP : if positive, then skip to leave below heading, 258 | % else - skip to leave to right of run-in heading. 259 | % STYLE : commands to set style 260 | % If '*' missing, then increments the counter. If it is present, then 261 | % there should be no [ALTHEADING] argument. A sectioning command 262 | % is normally defined to \@startsection + its first six arguments. 263 | 264 | \def\section{\@startsection {section}{1}{\z@}{-3.5ex plus-1ex minus 265 | -.2ex}{2.3ex plus.2ex}{\reset@font\Large\bf}} 266 | \def\subsection{\@startsection{subsection}{2}{\z@}{-3.25ex plus-1ex 267 | minus-.2ex}{1.5ex plus.2ex}{\reset@font\large\bf}} 268 | \def\subsubsection{\@startsection{subsubsection}{3}{\z@}{-3.25ex plus 269 | -1ex minus-.2ex}{1.5ex plus.2ex}{\reset@font\normalsize\bf}} 270 | \def\paragraph{\@startsection 271 | {paragraph}{4}{\z@}{3.25ex plus1ex minus.2ex}{-1em}{\reset@font 272 | \normalsize\bf}} 273 | \def\subparagraph{\@startsection 274 | {subparagraph}{4}{\parindent}{3.25ex plus1ex minus 275 | .2ex}{-1em}{\reset@font\normalsize\bf}} 276 | 277 | 278 | % Default initializations of \...mark commands. (See below for their 279 | % use in defining page styles. 280 | % 281 | 282 | % \def\sectionmark#1{} % Preloaded definitions 283 | % \def\subsectionmark#1{} 284 | % \def\subsubsectionmark#1{} 285 | % \def\paragraphmark#1{} 286 | % \def\subparagraphmark#1{} 287 | 288 | % The value of the counter secnumdepth gives the depth of the 289 | % highest-level sectioning command that is to produce section numbers. 290 | % 291 | 292 | \setcounter{secnumdepth}{3} 293 | 294 | % APPENDIX 295 | % 296 | % The \appendix command must do the following: 297 | % -- reset the section and subsection counters to zero 298 | % -- redefine the section counter to produce appendix numbers 299 | % -- redefine the \section command if appendix titles and headings 300 | % are to look different from section titles and headings. 301 | 302 | \def\appendix{\par 303 | \setcounter{section}{0} 304 | \setcounter{subsection}{0} 305 | \def\thesection{\Alph{section}}} 306 | 307 | 308 | % **************************************** 309 | % * LISTS * 310 | % **************************************** 311 | % 312 | 313 | % The following commands are used to set the default values for the list 314 | % environment's parameters. See the LaTeX manual for an explanation of 315 | % the meanings of the parameters. Defaults for the list environment are 316 | % set as follows. First, \rightmargin, \listparindent and \itemindent 317 | % are set to 0pt. Then, for a Kth level list, the command \@listK is 318 | % called, where 'K' denotes 'i', 'ii', ... , 'vi'. (I.e., \@listiii is 319 | % called for a third-level list.) By convention, \@listK should set 320 | % \leftmargin to \leftmarginK. 321 | % 322 | 323 | \leftmargini 2.5em 324 | \leftmarginii 2.2em % > \labelsep + width of '(m)' 325 | \leftmarginiii 1.87em % > \labelsep + width of 'vii.' 326 | \leftmarginiv 1.7em % > \labelsep + width of 'M.' 327 | \leftmarginv 1em 328 | \leftmarginvi 1em 329 | 330 | \leftmargin\leftmargini 331 | \labelsep .5em 332 | \labelwidth\leftmargini\advance\labelwidth-\labelsep 333 | %\parsep 4.5pt plus 2pt minus 1pt %(Removed 9 Jun 87) 334 | 335 | % \@listI defines top level and \@listi values of 336 | % \leftmargin, \topsep, \parsep, and \itemsep 337 | % (Added 9 Jun 87) 338 | \def\@listI{\leftmargin\leftmargini \parsep 4.5\p@ plus2\p@ minus\p@ 339 | \topsep \z@ \itemsep \topsep} 340 | 341 | \let\@listi\@listI 342 | \@listi 343 | 344 | \def\@listii{\leftmargin\leftmarginii 345 | \labelwidth\leftmarginii\advance\labelwidth-\labelsep 346 | \topsep \z@ \itemsep \topsep 347 | \parsep 2\p@ plus\p@ minus\p@} 348 | 349 | \def\@listiii{\leftmargin\leftmarginiii 350 | \labelwidth\leftmarginiii\advance\labelwidth-\labelsep 351 | \topsep \z@ \itemsep \topsep 352 | \parsep \z@ \partopsep\z@} 353 | 354 | \def\@listiv{\leftmargin\leftmarginiv 355 | \labelwidth\leftmarginiv\advance\labelwidth-\labelsep} 356 | 357 | 358 | 359 | 360 | 361 | %% RmS: which at the same time makes the vertical space in lists (verbatim...) 362 | %% too large if not other precautions are taken. 363 | \setlength{\parindent}{0pt} 364 | \setlength{\parskip}{6pt} 365 | \raggedbottom 366 | 367 | 368 | % Various boxes. 369 | \newlength{\reduceboxwidth} 370 | \setlength{\reduceboxwidth}{4in} 371 | 372 | \newlength{\redboxwidth} 373 | \setlength{\redboxwidth}{3.5in} 374 | 375 | \newlength{\rboxwidth} 376 | \setlength{\rboxwidth}{2.6in} 377 | 378 | % These are here in case the name changes or we someday want a special 379 | % font. 380 | \newcommand{\REDUCE}{REDUCE} 381 | \newcommand{\RLISP}{RLISP} 382 | 383 | % This is useful for putting function names in \tt format in the index. 384 | \newcommand{\ttindex}[1]{\index{#1@{\tt #1}}} 385 | 386 | % Use this when you are speaking about problems across systems. 387 | \newcommand{\COMPATNOTE}{{\em Compatibility Note:\ }} 388 | 389 | \pagestyle{headings} 390 | 391 | %% For BNF notation. 392 | 393 | % \s{...} is a sentential form in descriptions. Enclosed \em text in <...> 394 | \newcommand{\s}[1] {$<${\em #1}$>$} 395 | 396 | % \meta{...} is an alternative sentential form in descriptions using \it. 397 | \newcommand{\meta}[1]{\mbox{$\langle$\it#1\/$\rangle$}} 398 | 399 | % \k{...} is a keyword. Just do in bold for the moment. 400 | \@ifundefined{k}{}{\let\k\relax} % undefine \k (LaTeX2e) 401 | \newcommand{\k}[1] {{\bf #1}} 402 | 403 | % \f is a function name. Just do this as tt. 404 | \newcommand{\f}[1] {{\tt #1}} 405 | 406 | % An example macro for numbering and indenting examples. 407 | \newcounter{examplectr} 408 | \newcommand{\example}{\refstepcounter{examplectr} 409 | \noindent{\bf Example \theexamplectr}} 410 | 411 | % The following are currently only used in the GENTRAN document. However, 412 | % there's no objection to using them elsewhere. 413 | 414 | \begingroup 415 | \catcode `|=0 416 | \catcode `[= 1 417 | \catcode`]=2 418 | \catcode `\{=12 419 | \catcode `\}=12 420 | \catcode`\\=12 421 | |gdef|@xframedverbatim#1\end{framedverbatim}[#1|end[framedverbatim]] 422 | |gdef|@sxframedverbatim#1\end{framedverbatim*}[#1|end[framedverbatim*]] 423 | |endgroup 424 | 425 | \newdimen\@mcdheight 426 | 427 | \def\@sframedverbatim{\obeyspaces\@framedverbatim} 428 | 429 | \def\@mcdrule{\@mcdheight=\baselineskip\advance\@mcdheight by-2pt 430 | \setbox0=\hbox{\vrule height\@mcdheight depth 2pt width 1pt}% 431 | \ht0=\@mcdheight\dp0=0pt\wd0=1pt\box0} 432 | 433 | \def\@mcdendrule{\@mcdheight=\baselineskip% 434 | \setbox0=\hbox{\vrule height\@mcdheight depth 2pt width 1pt}% 435 | \ht0=\@mcdheight\dp0=0pt\wd0=1pt\box0} 436 | 437 | \def\@framedverbatim{\trivlist \item[] 438 | \parskip \z@ 439 | \hrule \@height \p@ \@depth \z@ \@width\textwidth 440 | \everypar{\global \@minipagefalse \global \@newlistfalse \if@inlabel 441 | \global \@inlabelfalse \hskip -\parindent \box \@labels \penalty \z@ \fi 442 | \hbox to6\p@{\rlap{\@mcdrule}\hskip\textwidth\llap{\@mcdrule}\hss}}% 443 | \if@minipage\else\vskip\parskip\fi 444 | \leftskip\@totalleftmargin\rightskip\z@ 445 | \parindent\z@\parfillskip\@flushglue\parskip\z@ 446 | \@tempswafalse \def\par{\if@tempswa\hbox{}\fi\@tempswatrue\@@par 447 | \penalty\interlinepenalty}% % fix \samepage bug 448 | \obeylines \tt \catcode``=13 \@noligs \let\do\@makeother \dospecials} 449 | 450 | \def\framedverbatim{\@framedverbatim \frenchspacing\@vobeyspaces 451 | \@xframedverbatim} 452 | 453 | \def\endframedverbatim{\nointerlineskip 454 | {\everypar{}\baselineskip 4\p@\vbox to4\p@{\par\noindent\hbox 455 | to6pt{\rlap{\@mcdendrule}\hskip\textwidth\llap{\@mcdendrule}\hss}}% 456 | \vskip\p@\hrule \@height \p@ \@depth \z@ \@width\textwidth}\endtrivlist} 457 | 458 | \@namedef{framedverbatim*}{\@framedverbatim\@sxframedverbatim} 459 | 460 | \expandafter\let\csname endframedverbatim*\endcsname =\endtrivlist 461 | 462 | % Will print out a heading in bold, and then indent the following text. 463 | \def\indented{\list{}{ 464 | \itemindent\listparindent 465 | \rightmargin\leftmargin}\item[]} 466 | \let\endindented=\endlist 467 | \newenvironment{describe}[1]{\par{\bf #1}\begin{indented}}{\end{indented}} 468 | 469 | \@ifundefined{reset@font}{\let\reset@font\@empty}{} 470 | 471 | \endinput 472 | -------------------------------------------------------------------------------- /manual/sl.bbl: -------------------------------------------------------------------------------- 1 | \begin{thebibliography}{10} 2 | 3 | \bibitem{CDC-LISP} 4 | Computation Center. 5 | \newblock {\em {LISP} Reference Manual, CDC-6000}. 6 | \newblock The University of Texas at Austin. 7 | 8 | \bibitem{LISP/360} 9 | Stanford~Center for Information~Processing. 10 | \newblock {\em {LISP/360} Reference Manual}. 11 | \newblock Stanford University. 12 | 13 | \bibitem{PLC} 14 | M.~L. Griss and A.~C. Hearn. 15 | \newblock A portable {LISP} compiler. 16 | \newblock {\em Software---Practice and Experience}, 11:541--605, June 1981. 17 | 18 | \bibitem{Hearn:69} 19 | A.~C. Hearn. 20 | \newblock Standard {LISP}. 21 | \newblock {\em SIGPLAN Notices}, 4:28--49, 1969. 22 | \newblock Reprinted in {SIGSAM} Bulletin, ACM, Vol. 13, 1969, p. 28-49. 23 | 24 | \bibitem{REDUCE3.3} 25 | A.~C. Hearn. 26 | \newblock {REDUCE} user's manual: Version 3.3. 27 | \newblock Publication CP78 (Rev 1/88), {RAND}, 1988. 28 | 29 | \bibitem{MACLISP} 30 | {\em {MACLISP} Reference Manual}, March 1976. 31 | 32 | \bibitem{LISP1.5} 33 | John McCarthy, Paul~W. Abrahams, Daniel~J. Edwards, Timothy~P. Hart, and 34 | Michael~I. Levin. 35 | \newblock {\em {LISP} 1.5 Programmers Manual}. 36 | \newblock The {M.I.T.} Press, Cambridge, Massachusettes, 1965. 37 | 38 | \bibitem{LISPF1} 39 | Mats Nordstrom, Erik Sandewall, and Diz Breslow. 40 | \newblock {\em {LISP F1}: A {FORTRAN} Implementation of {LISP} 1.5}. 41 | \newblock Uppsala University, Department of Computer Sciences. 42 | 43 | \bibitem{LISP1.6} 44 | Lynn~H. Quam and Whitfield Diffie. 45 | \newblock {\em Stanford {LISP} 1.6 Manual}. 46 | \newblock Stanford Artificial Intelligence Laboratory, operating note 28.7 47 | edition. 48 | 49 | \bibitem{Interlisp} 50 | Warren Teitelman. 51 | \newblock {\em {INTERLISP} Reference Manual}. 52 | \newblock {XEROX}, Palo Alto Research Centers, 3333 Coyote Road, Palo Alto, 53 | California 94304, 1978. 54 | 55 | \end{thebibliography} 56 | -------------------------------------------------------------------------------- /manual/sl.bib: -------------------------------------------------------------------------------- 1 | @String{SPE="Software---Practice and Experience"} 2 | 3 | @ARTICLE{Hearn:69, 4 | AUTHOR = "A. C. Hearn", 5 | TITLE = "Standard {LISP}", 6 | JOURNAL = "SIGPLAN Notices", 7 | YEAR = 1969, VOLUME = 4, PAGES = "28-49", 8 | NOTE = "Reprinted in {SIGSAM} Bulletin, ACM, Vol. 13, 1969, p. 28-49"} 9 | 10 | @ARTICLE{PLC, 11 | AUTHOR="M. L. Griss and A. C. Hearn", 12 | TITLE = "A Portable {LISP} Compiler", 13 | JOURNAL=SPE, 14 | MONTH = "June", 15 | YEAR=1981, VOLUME=11, PAGES="541-605", 16 | ANNOTE="Also as UUCS-79-113, and UCP-76"} 17 | 18 | @MANUAL{CDC-LISP, 19 | KEY = "CDC", 20 | TITLE = "{LISP} Reference Manual, CDC-6000", 21 | AUTHOR = "Computation Center", 22 | ORGANIZATION= "The University of Texas at Austin"} 23 | 24 | @MANUAL{LISP/360, 25 | KEY = "LISP/360", 26 | TITLE = "{LISP/360} Reference Manual", 27 | AUTHOR = "Stanford Center for Information Processing", 28 | ORGANIZATION = "Stanford University"} 29 | 30 | @BOOK{LISP1.5, 31 | AUTHOR = "John McCarthy and Paul W. Abrahams and Daniel J. Edwards and 32 | Timothy P. Hart and Michael I. Levin", 33 | TITLE = "{LISP} 1.5 Programmers Manual", 34 | ORGANIZATION = "The Computation Center and Research Laboratory of 35 | Electronics, Massachusettes Institute of Technology", 36 | PUBLISHER = "The {M.I.T.} Press", 37 | ADDRESS = "Cambridge, Massachusettes", YEAR = 1965} 38 | 39 | @MANUAL{MACLISP, 40 | KEY = "MACLISP", 41 | TITLE = "{MACLISP} Reference Manual", 42 | MONTH = "March", YEAR = 1976} 43 | 44 | @MANUAL{LISPF1, 45 | AUTHOR = "Mats Nordstrom and Erik Sandewall and Diz Breslow", 46 | TITLE = "{LISP F1}: A {FORTRAN} Implementation of {LISP} 1.5", 47 | ORGANIZATION = "Uppsala University, Department of Computer Sciences"} 48 | 49 | @MANUAL{LISP1.6, 50 | AUTHOR = "Lynn H. Quam and Whitfield Diffie", 51 | TITLE = "Stanford {LISP} 1.6 Manual", 52 | ORGANIZATION = "Stanford Artificial Intelligence Laboratory", 53 | EDITION ="Operating Note 28.7"} 54 | 55 | @TECHREPORT{REDUCE3.3, 56 | AUTHOR = "A. C. Hearn", 57 | TITLE = "{REDUCE} User's Manual: Version 3.3", 58 | INSTITUTION = "{RAND}", 59 | TYPE = "Publication", NUMBER = "CP78 (Rev 1/88)", YEAR = 1988} 60 | 61 | @MANUAL{Interlisp, 62 | AUTHOR = "Warren Teitelman", 63 | TITLE = "{INTERLISP} Reference Manual", 64 | ORGANIZATION = "{XEROX}", 65 | ADDRESS = "Palo Alto Research Centers, 3333 Coyote Road, Palo Alto, 66 | California 94304", 67 | YEAR = 1978} 68 | -------------------------------------------------------------------------------- /manual/sl.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/blakemcbride/PSL/f489ea67801d04d44cc65d63365d187cdd58dbe9/manual/sl.pdf -------------------------------------------------------------------------------- /sizes.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "flags.l" 3 | 4 | typedef int *PSEXP, **PPSEXP; 5 | 6 | #if BITF 7 | struct Xid { 8 | char Xtype; 9 | int Xisinheap : 1; 10 | int Xisglobal : 1; 11 | int Xisfluid : 1; 12 | int Xisfunction : 1; 13 | int Xisinoblist : 1; 14 | int Xisdclfluid : 1; 15 | struct Xid *Xhashlink; 16 | PSEXP Xvalue; 17 | PSEXP Xproplist; 18 | char *Xpname; 19 | }; 20 | #else 21 | struct Xid { 22 | char Xtype; 23 | char Xattr; 24 | struct Xid *Xhashlink; 25 | PSEXP Xvalue; 26 | PSEXP Xproplist; 27 | char *Xpname; 28 | }; 29 | #endif 30 | 31 | struct Xpair { 32 | char Xtype; 33 | PSEXP Xcar; 34 | PSEXP Xcdr; 35 | }; 36 | 37 | struct Xstring { 38 | char Xtype; 39 | struct Xstrelmnt *Xstrbody; 40 | }; /*Changed in ver 3.3*/ 41 | 42 | typedef struct Xstring STRING, *PSTRING; 43 | 44 | struct Xstrelmnt { 45 | char Xlength; /*New in ver 3.3*/ 46 | PSTRING Xbackpointer; 47 | char Xrealstr[254]; 48 | }; 49 | 50 | struct Xinteger { 51 | char Xtype; 52 | long int Xintval; 53 | }; 54 | struct Xbig { 55 | char Xtype; 56 | long int Xintval; 57 | PSEXP Xcdr; 58 | }; 59 | struct Xfloating { 60 | char Xtype; 61 | double Xfloval; 62 | }; 63 | struct Xvector { 64 | char Xtype; 65 | int Xupbv; 66 | PSEXP *Xvectelts; 67 | char Xused; 68 | }; 69 | struct Xfpointer { 70 | char Xtype; 71 | char Xargno; 72 | int (*Xfnc)(); 73 | }; 74 | struct Xerrmsg { 75 | char Xtype; 76 | int Xerrorno; 77 | PSEXP Xerrormsg; 78 | }; 79 | 80 | 81 | 82 | typedef struct Xid ID, *PID; 83 | typedef struct Xpair PAIR, *PPAIR; 84 | typedef struct Xinteger INTEGER, *PINTEGER; 85 | typedef struct Xbig BIG, *PBIG; 86 | typedef struct Xfloating FLOATING, *PFLOATING; 87 | typedef struct Xvector VECTOR, *PVECTOR; 88 | typedef struct Xfpointer FPOINTER, *PFPOINTER; 89 | typedef struct Xerrmsg ERRMSG, *PERRMSG; 90 | typedef struct Xstrelmnt STRELEMENT, *PSTRELEMENT; 91 | 92 | 93 | unsigned sz[] = { 94 | sizeof(PAIR), 95 | sizeof(ID), 96 | sizeof(STRING), 97 | sizeof(INTEGER), 98 | sizeof(BIG), 99 | sizeof(FLOATING), 100 | sizeof(VECTOR), 101 | sizeof(char), 102 | sizeof(int), 103 | sizeof(long), 104 | sizeof(PSEXP), 105 | sizeof(double), 106 | sizeof(long long) 107 | }; 108 | 109 | long gcd(long m, long n) 110 | { 111 | if (n == 0) 112 | return m; 113 | if (n > m) 114 | return gcd(n, m); 115 | return gcd(n, m % n); 116 | } 117 | 118 | 119 | int main(void) 120 | { 121 | int i; 122 | long j = 1; 123 | /* double d1=2.,d2=1.; */ 124 | 125 | printf(" size of PAIR %d\n", sz[0]); 126 | printf(" size of ID %d\n", sz[1]); 127 | printf(" size of STRING %d\n", sz[2]); 128 | printf(" size of INTEGER %d\n", sz[3]); 129 | printf(" size of BIG %d\n", sz[4]); 130 | printf(" size of FLOATING %d\n", sz[5]); 131 | printf(" size of VECTOR %d\n", sz[6]); 132 | printf("--------------------------\n"); 133 | printf(" size of char %d\n", sz[7]); 134 | printf(" size of int %d\n", sz[8]); 135 | printf(" size of long int %d\n", sz[9]); 136 | printf(" size of PSEXP %d\n", sz[10]); 137 | printf(" size of double %d\n", sz[11]); 138 | printf(" size of long long %d\n", sz[12]); 139 | for (i = 0 ; i < 8 ; i++) 140 | j = (j / gcd(j, (long) sz[i])) * sz[i]; /* LCM of all sz[i] */ 141 | printf(" Set PAGESIZE to n positive integer multiple of: %ld\n", j); 142 | /* while((long)d1 != (long) d2) 143 | { d1 = d2; 144 | d2 *= 2; } 145 | printf("\n mantissa size of double is %g \n", d1); */ 146 | return 0; 147 | } 148 | -------------------------------------------------------------------------------- /sysid.l: -------------------------------------------------------------------------------- 1 | nil 18 nil NIL 2 | cmod1 18 *mod NIL 3 | emsg 18 emsg* NIL 4 | comp 18 *comp NIL 5 | raise1 18 *raise NIL 6 | echo 18 *echo NIL 7 | gcflag 18 *gcflag NIL 8 | eol 18 $eol$ Sexp(&eol) 9 | eof 18 $eof$ Sexp(&eof) 10 | expr 2 expr NULL 11 | fexpr 2 fexpr NULL 12 | subr 2 subr NULL 13 | fsubr 2 fsubr NULL 14 | macro 2 macro NULL 15 | lambda 2 lambda NULL 16 | inpt 2 input NULL 17 | outpt 2 output NULL 18 | nerrmsg 2 errmsg NULL 19 | npair 2 pair NULL 20 | nid 2 id NULL 21 | nstring 2 string NULL 22 | ninteger 2 integer NULL 23 | nfloating 2 floating NULL 24 | nvector 2 vector NULL 25 | nfpointer 2 nfpointer NULL 26 | prompt 18 *prompt NIL 27 | trace 2 trace NULL 28 | begin 2 begin NIL 29 | -------------------------------------------------------------------------------- /sysids.l: -------------------------------------------------------------------------------- 1 | nil 0 1 0 0 1 0 nil NIL 2 | cmod1 0 1 0 0 1 0 *mod NIL 3 | emsg 0 1 0 0 1 0 emsg* NIL 4 | comp 0 1 0 0 1 0 *comp NIL 5 | raise1 0 1 0 0 1 0 *raise NIL 6 | echo 0 0 1 0 1 0 *echo NIL 7 | gcflag 0 1 0 0 1 0 *gcflag NIL 8 | eol 0 1 0 0 1 0 $eol$ Sexp(&eol) 9 | eof 0 1 0 0 1 0 $eof$ Sexp(&eof) 10 | expr 0 0 0 0 1 0 expr NULL 11 | fexpr 0 0 0 0 1 0 fexpr NULL 12 | subr 0 0 0 0 1 0 subr NULL 13 | fsubr 0 0 0 0 1 0 fsubr NULL 14 | macro 0 0 0 0 1 0 macro NULL 15 | lambda 0 0 0 0 1 0 lambda NULL 16 | inpt 0 0 0 0 1 0 input NULL 17 | outpt 0 0 0 0 1 0 output NULL 18 | nerrmsg 0 0 0 0 1 0 errmsg NULL 19 | npair 0 0 0 0 1 0 pair NULL 20 | nid 0 0 0 0 1 0 id NULL 21 | nstring 0 0 0 0 1 0 string NULL 22 | ninteger 0 0 0 0 1 0 integer NULL 23 | nfloating 0 0 0 0 1 0 floating NULL 24 | nvector 0 0 0 0 1 0 vector NULL 25 | nfpointer 0 0 0 0 1 0 nfpointer NULL 26 | prompt 0 1 0 0 1 0 *prompt NIL 27 | trace 0 0 0 0 1 0 trace NULL 28 | begin 0 0 0 0 1 0 begin NIL 29 | -------------------------------------------------------------------------------- /tests/BigNTest.lsp: -------------------------------------------------------------------------------- 1 | (de fac (n) 2 | (cond ((eq n 0) 1) 3 | (t (times n (fac (difference n 1)))) 4 | ) 5 | ) 6 | (de ttt nil (progn 7 | (print (setq l (fac 15))) 8 | (print (setq i (times l 77))) 9 | (quotient i l) )) 10 | 11 | -------------------------------------------------------------------------------- /tests/test.lsp: -------------------------------------------------------------------------------- 1 | (de fac (n) 2 | (cond ((eq n 0) 1) 3 | (t (times n (fac (difference n 1)))) 4 | ) 5 | ) 6 | 7 | (de test!-bolu nil 8 | (prog (i j k l) 9 | (setq l 5) 10 | l2 (prin1 l) (prin2 "-->") 11 | (print (setq j (fac l))) 12 | (setq i 2) 13 | l1 (cond ((eqn i 1300) (go l3))) 14 | (setq k (times j i)) 15 | (cond ((not (eqn i (car (divide k j)))) (progn (prin1 i) (prin1 (divide k j)) (print "hata 1")))) 16 | (cond ((not (zerop (cdr (divide k j)))) (progn (prin1 i) (prin1 (divide k j)) (print "hata 2")))) 17 | (cond ((not (eqn j (car (divide k i)))) (progn (prin1 i) (prin1 (divide k i)) (print "hata 3")))) 18 | (cond ((not (zerop (cdr (divide k i)))) (progn (prin1 i) (prin1 (divide k i)) (print "hata 4")))) 19 | (setq i (add1 i)) 20 | (go l1) 21 | l3 (setq l (add1 l)) 22 | (cond ((eqn l 148) (return l)) 23 | (t (go l2))) 24 | ) 25 | ) 26 | 27 | (test!-bolu) 28 | -------------------------------------------------------------------------------- /type.l: -------------------------------------------------------------------------------- 1 | #define reg1 registers[0] 2 | #define reg2 registers[1] 3 | #define reg3 registers[2] 4 | #define reg4 registers[3] 5 | #define reg5 registers[4] 6 | #define reg6 registers[5] 7 | #define reg7 registers[6] 8 | #define reg8 registers[7] 9 | #define reg9 registers[8] 10 | #define reg10 registers[9] 11 | #define reg11 registers[10] 12 | #define reg12 registers[11] 13 | #define reg13 registers[12] 14 | #define reg14 registers[13] 15 | #define reg15 registers[14] 16 | #define reg16 registers[15] 17 | 18 | #define M_ONE small_num[0] 19 | #define ZERO small_num[1] 20 | #define ONE small_num[2] 21 | #define TWO small_num[3] 22 | #define THREE small_num[4] 23 | #define FOUR small_num[5] 24 | #define FIVE small_num[6] 25 | #define SIX small_num[7] 26 | #define SEVEN small_num[8] 27 | 28 | #if DSTACK 29 | #define saveregisters(n) memcpy(zstackptr - (n) + 1, registers + 1, (n) * sizeof(PSEXP)) 30 | #define restoreregisters(n) memcpy(registers + 1, zstackptr - (n) + 1, (n) * sizeof(PSEXP)) 31 | #else 32 | #define saveregisters(n) memcpy(zstackp + zstackptr - (n) + 1, registers + 1, (n) * sizeof(PSEXP)) 33 | #define restoreregisters(n) memcpy(registers + 1, zstackp + zstackptr - (n) + 1, (n) * sizeof(PSEXP)) 34 | #endif 35 | 36 | #define Spair(x) ((PPAIR) (x)) 37 | #define Sid(x) ((PID) (x)) 38 | #define Sstr(x) ((PSTRING) (x)) 39 | #define Sfix(x) ((PINTEGER) (x)) 40 | #define Sbig(x) ((PBIG) (x)) 41 | #define Sfloat(x) ((PFLOATING) (x)) 42 | #define Svector(x) ((PVECTOR) (x)) 43 | #define Scode(x) ((PFPOINTER) (x)) 44 | #define Serrmsg(x) ((PERRMSG) (x)) 45 | #define Sforwardadr(x)((PFORWARDADR) (x)) /*v 6.0 *GU*/ 46 | #define Sstrelement(x) ((char *) (x)) 47 | 48 | 49 | 50 | #define null(x) ((x) == NIL) 51 | #define type(x) (Sid(x)->Xtype ) 52 | #define pairp(x) (Sid(x)->Xtype == Tpair) 53 | #define atom(x) (Sid(x)->Xtype != Tpair) 54 | #define idp(x) (Sid(x)->Xtype == Tid) 55 | #define stringp(x) (Sid(x)->Xtype == Tstring) 56 | #define fixp(x) (Sid(x)->Xtype == Tinteger) 57 | #define bigp(x) (Sid(x)->Xtype == Tbig) 58 | #define floatp(x) (Sid(x)->Xtype == Tfloating) 59 | #define vectorp(x) (Sid(x)->Xtype == Tvector) 60 | #define codep(x) (Sid(x)->Xtype == Tfpointer) 61 | #define errmsgp(x) (Sid(x)->Xtype == Terrmsg) 62 | #define forwarded(x) (Sid(x)->Xtype == Tforwardadr) /*v 6.0 *GU*/ 63 | #define numberp(x) (fixp(x) || bigp(x) || floatp(x)) 64 | #define constantp(x) (!idp(x) && !pairp(x)) 65 | #if BITF 66 | #define inheap(x) (Sid(x)->Xisinheap) 67 | #define globalp(x) (Sid(x)->Xisglobal) 68 | #define fluidp(x) (Sid(x)->Xisfluid) 69 | #define functionp(x) (Sid(x)->Xisfunction) 70 | #define dclfluidp(x) (Sid(x)->Xisdclfluid) 71 | #define inoblistp(x) (Sid(x)->Xisinoblist) 72 | #else 73 | #define attribute(x) (Sid(x)->Xattr) 74 | #define inheap(x) (attribute(x) & 0x20) 75 | #define globalp(x) (attribute(x) & 0x10) 76 | #define fluidp(x) (attribute(x) & 0x08) 77 | #define functionp(x) (attribute(x) & 0x04) 78 | #define inoblistp(x) (attribute(x) & 0x02) 79 | #define dclfluidp(x) (attribute(x) & 0x01) 80 | #endif 81 | 82 | #define floval(x) (Sfloat(x)->Xfloval) 83 | #define hashlink(x) (Sid(x)->Xhashlink) 84 | #define intval(x) (Sfix(x)->Xintval) 85 | #define bigval(x) (Sbig(x)->Xintval) 86 | #define bigcdr(x) (Sbig(x)->Xcdr) 87 | #define pname(x) (Sid(x)->Xpname) 88 | #define proplist(x) (Sid(x)->Xproplist) 89 | #define value(x) (Sid(x)->Xvalue) 90 | #define strelement(x) (Sstr(x)->Xstrelement) 91 | #define strbody(x) (strelement(x) + STROFFSET) 92 | #define elmbody(x) (((char *) (x)) + STROFFSET) 93 | #define father(x) (strelement(x) + sizeof(char)) 94 | #define elmfather(x) (((char *) (x)) + sizeof(char)) 95 | #define storeelmfather(e, x) ((dummystrptr = Sstr(x), \ 96 | movmem((char *) &dummystrptr, (char *)elmfather(e), sizeof(PSTRING)))) 97 | #define setfather(x) (storeelmfather(strelement(x), x)) 98 | #define getelmfather(e) \ 99 | ((movmem((char *)elmfather(e), (char *) &dummystrptr, sizeof(PSTRING)), \ 100 | dummystrptr)) 101 | #define elmlength(x) (*((char *) (x))) 102 | #define strlength(x) (*(strelement(x))) 103 | #define upbv(x) (Svector(x)->Xupbv) 104 | #define usedvec(x) (Svector(x)->Xused) 105 | #define vectelt(x, n) (vectelts(x)[n]) 106 | #define vectelts(x) (Svector(x)->Xvectelts) 107 | #define forwardadr(x) (Sforwardadr(x)->Xforwardaddress) /*v 6.0 *GU*/ 108 | #define argno(x) (Scode(x)->Xargno) 109 | #define fnc(x) (*(Scode(x)->Xfnc)) 110 | #define errorno(x) (Serrmsg(x)->Xerrorno) 111 | #define errormsg(x) (Serrmsg(x)->Xerrormsg) 112 | #define caadr(x) (car(car(cdr(x)))) 113 | #define caar(x) (car(car(x))) 114 | #define cadar(x) (car(cdr(car(x)))) 115 | #define cadddr(x) (car(cdr(cdr(cdr(x))))) 116 | #define caddr(x) (car(cdr(cdr(x)))) 117 | #define cadr(x) (car(cdr(x))) 118 | #define car(x) (Spair(x)->Xcar) 119 | #define cdadr(x) (cdr(car(cdr(x)))) 120 | #define cdar(x) (cdr(car(x))) 121 | #define cddddr(x) (cdr(cdr(cdr(cdr(x))))) 122 | #define cdddr(x) (cdr(cdr(cdr(x)))) 123 | #define cddr(x) (cdr(cdr(x))) 124 | #define cdr(x) (Spair(x)->Xcdr) 125 | 126 | #define STACKSIZE 3500 /*size of stack */ 127 | #if SLOWSTACK /*alternative stack manipulation definitions*/ 128 | #if DSTACK 129 | #define kpop(n) kpops(n) 130 | #define kset(n, x) ksets(n, &(x)) 131 | #define kload(x, n) kloads(&(x), n) 132 | #define local(n) (*(zstackptr - n)) 133 | #define local0 (*zstackptr) 134 | #define kset0(x) ksets(0, &(x)) 135 | #define kload0(x) kloads(&(x), 0) 136 | #else 137 | #define kpop(n) (zstackptr -= n) 138 | #define kset(n, x) ksets(n, &(x)) 139 | #define kload(x, n) kloads(&(x), n) 140 | #define local(n) (zstackp[zstackptr - n]) 141 | #define local0 (zstackp[zstackptr]) 142 | #define kset0(x) ksets(0, &(x)) 143 | #define kload0(x) kloads(&(x), 0) 144 | #endif 145 | #else 146 | #if DSTACK 147 | #define kpop(n) (zstackptr -= n) 148 | #define kset(n, x) (*(zstackptr - n) = x) 149 | #define kload(x, n) (x = *(zstackptr - n)) 150 | #define local(n) (*(zstackptr - n)) 151 | #define local0 (*zstackptr) 152 | #define kset0(x) (*zstackptr = x) 153 | #define kload0(x) (x = *zstackptr) 154 | #else 155 | #define kpop(n) (zstackptr -= n) 156 | #define kset(n, x) (zstackp[zstackptr - n] = x) 157 | #define kload(x, n) (x = zstackp[zstackptr - n]) 158 | #define local(n) (zstackp[zstackptr - n]) 159 | #define local0 (zstackp[zstackptr]) 160 | #define kset0(x) (zstackp[zstackptr] = x) 161 | #define kload0(x) (x = zstackp[zstackptr]) 162 | #endif 163 | #endif 164 | 165 | #define zreturn(x) { reg1 = (x); return; } 166 | #define zkreturn(x, n) { reg1 = (x); kpop(n); return; } 167 | 168 | #define ch(x) (Sexp(&chrid[(x)])) 169 | 170 | struct alistentry { 171 | PSEXP alistid; 172 | PSEXP alistval; 173 | }; 174 | 175 | typedef struct alistentry ALISTENT, *PALISTENT; 176 | 177 | #define NTYPES 7 178 | #define STROFFSET (sizeof(char) + sizeof(PSTRING)) 179 | #define STROFFSET2 (STROFFSET + 1) 180 | 181 | 182 | 183 | struct page { 184 | struct page *nextpage; 185 | PSEXP free; 186 | char pagebd[PAGESIZE]; 187 | }; 188 | 189 | typedef struct page PAGE, *PPAGE; 190 | #if DSTACK 191 | struct errortrap { 192 | jmp_buf errsave; 193 | PPSEXP stacksave; 194 | PALISTENT curalist; 195 | unsigned msgprint : 1; 196 | unsigned backtrace : 1; 197 | }; 198 | #else 199 | struct errortrap { 200 | jmp_buf errsave; 201 | int stacksave; 202 | PALISTENT curalist; 203 | unsigned msgprint : 1; 204 | unsigned backtrace : 1; 205 | }; 206 | #endif 207 | 208 | typedef struct errortrap ERRORTRAP; 209 | 210 | #define putmark(x) (type(x) |= 0x80) 211 | #define clrmark(x) (type(x) &= 0x7f) 212 | #define marked(x) (type(x) & 0x80) 213 | #define gtype(x) (type(x) & 0x7f) 214 | 215 | #define cnewline currlin++; \ 216 | if (pageln && currlin >= pageln) \ 217 | {putc('\f', outputf); currlin = 0; } 218 | 219 | #define longd(x) ((double)(x)) 220 | #define longdbl double 221 | 222 | #ifndef labs 223 | #define labs(x) ((x) < 0 ? -(x) : (x)) 224 | #endif 225 | #ifndef fabs 226 | #define fabs(x) ((x) < 0.0 ? -(x) : (x)) 227 | #endif 228 | 229 | #ifndef min 230 | #define min(a, b) (((a) < (b)) ? (a) : (b)) 231 | #endif 232 | -------------------------------------------------------------------------------- /types.l: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | 9 | typedef char *PCHAR; 10 | #define myalloc(x) malloc(x) 11 | 12 | #define DZ 8 /* # of decimal digits in one cell */ 13 | #define BASE 100000000L /* 10**DZ */ 14 | #define BM1 99999999L /* 10**DZ -1 */ 15 | #define BFT 10000000000000000.0 /* 10**(2*DZ) */ 16 | 17 | #define BN 2147483647L /* biggest positive # on long int type */ 18 | /* completely machine dependent PAGESIZE. use 'size.c' in order 19 | to find this number. 20 | rule: 'product of all sizes' mod PAGESIZE should be zero. */ 21 | 22 | #define PAGESIZE 12000 23 | #define TXSIZE 121 24 | 25 | /* big integer arithmetic machine specific constants */ 26 | 27 | /* 9223372036854775810 (64 bits) number for 10 byte double */ 28 | /* 4503599627370497 (53 bits) number for 8 byte double */ 29 | 30 | typedef int *PSEXP, **PPSEXP; 31 | 32 | #if BITF 33 | struct Xid { 34 | char Xtype; 35 | unsigned Xisinheap : 1; 36 | unsigned Xisglobal : 1; 37 | unsigned Xisfluid : 1; 38 | unsigned Xisfunction : 1; 39 | unsigned Xisinoblist : 1; 40 | unsigned Xisdclfluid : 1; 41 | struct Xid *Xhashlink; 42 | PSEXP Xvalue; 43 | PSEXP Xproplist; 44 | char *Xpname; 45 | }; 46 | #else 47 | struct Xid { 48 | char Xtype; 49 | char Xattr; 50 | struct Xid *Xhashlink; 51 | PSEXP Xvalue; 52 | PSEXP Xproplist; 53 | char *Xpname; 54 | }; 55 | #endif 56 | 57 | struct Xpair { 58 | char Xtype; 59 | PSEXP Xcar; 60 | PSEXP Xcdr; 61 | }; 62 | 63 | struct Xstring { 64 | char Xtype; /* Added in 7.0 */ 65 | char *Xstrelement; 66 | }; 67 | 68 | typedef struct Xstring STRING, *PSTRING; 69 | 70 | struct Xinteger { 71 | char Xtype; 72 | long int Xintval; 73 | }; 74 | struct Xbig { 75 | char Xtype; 76 | long int Xintval; 77 | PSEXP Xcdr; 78 | }; 79 | struct Xfloating { 80 | char Xtype; 81 | double Xfloval; 82 | }; 83 | struct Xvector { 84 | char Xtype; 85 | int Xupbv; 86 | PSEXP *Xvectelts; 87 | char Xused; 88 | }; 89 | struct Xfpointer { 90 | char Xtype; 91 | char Xargno; 92 | void (*Xfnc)(); 93 | }; 94 | struct Xerrmsg { 95 | char Xtype; 96 | int Xerrorno; 97 | PSEXP Xerrormsg; 98 | }; 99 | 100 | struct Xforwardadr { 101 | char Xtype; /*v 6.0 *GU*/ 102 | PSEXP Xforwardaddress; 103 | }; /*v 6.0 *GU*/ 104 | 105 | typedef struct Xid ID, *PID; 106 | typedef struct Xpair PAIR, *PPAIR; 107 | typedef struct Xinteger INTEGER, *PINTEGER; 108 | typedef struct Xbig BIG, *PBIG; 109 | typedef struct Xfloating FLOATING, *PFLOATING; 110 | typedef struct Xvector VECTOR, *PVECTOR; 111 | typedef struct Xfpointer FPOINTER, *PFPOINTER; 112 | typedef struct Xerrmsg ERRMSG, *PERRMSG; 113 | typedef struct Xforwardadr FORWARDADR, *PFORWARDADR; /*v 6.0 *GU*/ 114 | 115 | #define Tpair 0 116 | #define Tid 1 117 | #define Tstring 2 118 | #define Tinteger 3 119 | #define Tbig 4 120 | #define Tfloating 5 121 | #define Tvector 6 122 | #define Tfpointer 7 123 | #define Terrmsg 8 124 | #define Tpname 9 125 | #define Tsname 10 126 | #define Tforwardadr 11 127 | #define Tuser 12 128 | 129 | #define Sexp(x) ((PSEXP) (x)) 130 | 131 | #define T (Sexp(&chrid['t'])) 132 | #define NIL (Sexp(&nil)) 133 | -------------------------------------------------------------------------------- /uncrustify.config: -------------------------------------------------------------------------------- 1 | nl_after_semicolon = True 2 | nl_after_vbrace_open = True 3 | sp_before_sparen = Add 4 | sp_assign = Add 5 | sp_arith = Add 6 | mod_paren_on_return = Remove 7 | sp_compare = Add 8 | sp_paren_paren = Remove 9 | sp_sparen_brace = Force 10 | sp_paren_brace = Force 11 | sp_after_byref = Remove 12 | sp_after_ptr_star = Remove 13 | sp_after_comma = Add 14 | sp_else_brace = Force 15 | sp_brace_else = Force 16 | nl_after_brace_open = True 17 | nl_if_brace = Remove 18 | nl_elseif_brace = Remove 19 | nl_else_if = Remove 20 | nl_else_brace = Remove 21 | nl_brace_finally = Remove 22 | nl_brace_else = Remove 23 | sp_before_semi_for = Force 24 | sp_before_semi_for_empty = Remove 25 | nl_while_brace = Remove 26 | nl_for_brace = Remove 27 | nl_catch_brace = Remove 28 | nl_do_brace = Remove 29 | nl_brace_while = Remove 30 | nl_switch_brace = Remove 31 | nl_class_brace = Remove 32 | nl_fdef_brace = Add 33 | mod_remove_extra_semicolon = True 34 | nl_after_case = True 35 | nl_after_label_colon = True 36 | 37 | -------------------------------------------------------------------------------- /yylex.l: -------------------------------------------------------------------------------- 1 | /* A LISP primitive tokenizer to be used with the STD-LISP interpreter 2 | written by E. Karabudak. Shall play the role of yylex of UNIX. 3 | 4 | * main function is yylex ... returns parsed expression bit in yytext 5 | * expects source from 'inputf' .. a filepointer 6 | * the pattern matcher tries to apply the test functions 7 | is....() 8 | these functions are responsible of disposing the characters which 9 | they have consumed by advancing the curpos pointer to the next 10 | virgin character. But if their test is unsuccessfull then it 11 | is also the responsebility of the function to back the pointer 12 | curpos to the point where that test function was entered, that 13 | means it has to restore the virginity... funny ehh!? 14 | */ 15 | 16 | /* INPUTBUFLEN shall be minimum 200 */ 17 | 18 | #define INPUTBUFLEN 300 19 | 20 | char input[INPUTBUFLEN]; /* input buffer */ 21 | /*char *curpos; Has to be initialized to point to '0' in main */ 22 | char *lastpos; /* Holds first position to start match on */ 23 | char *endpos; /* Holds the last position of input array 7.1 TY */ 24 | char signflag; /* is 1/0 depending on whether sign is allowed or not */ 25 | char *ch1, *ch2; 26 | 27 | /* The below is new in ver 7.0 */ 28 | /* corrects the problem of rds() change => lose of unconsumed sexprs in input buffer */ 29 | /* additionally this part now keeps track the open files 7.1 TY */ 30 | 31 | #define INPUTSAVETABLESIZE 100 32 | 33 | typedef 34 | struct INPUT_BUF_SAVE_ENTRY 35 | { 36 | FILE *file; 37 | char *curpos; 38 | char *lastpos; 39 | char input[INPUTBUFLEN]; 40 | } INPUT_BUF_SAVE_ENTRY; 41 | 42 | INPUT_BUF_SAVE_ENTRY input_buf_save_table[INPUTSAVETABLESIZE]; 43 | 44 | /* end of ver 7.0 new part */ 45 | 46 | 47 | 48 | 49 | void exponent(), sign(), digits(); 50 | int soffinteger(); 51 | 52 | /* PATTERN : 1 */ 53 | void incr_curpos () /* needed for isstring 7.1 TY */ 54 | { 55 | if (curpos < endpos) 56 | curpos++; 57 | else 58 | zerror(44); 59 | } 60 | 61 | 62 | int isstring() 63 | { 64 | if (*curpos != '"') 65 | return 0; 66 | cont: 67 | incr_curpos (); 68 | while (*curpos != '"') 69 | incr_curpos (); 70 | incr_curpos (); 71 | if (*curpos == '"') 72 | goto cont; 73 | return 1; 74 | } 75 | 76 | /* PATTERN : 2 */ 77 | 78 | int isexl() 79 | { 80 | if (*curpos != '!') 81 | return 0; 82 | curpos++; 83 | return 1; 84 | } 85 | 86 | int isid() 87 | { 88 | if ((!isexl()) && (!isalpha(*curpos))) 89 | return 0; 90 | else 91 | curpos++; 92 | while (isalnum(*curpos) || isexl()) 93 | curpos++; /*patch 1*/ 94 | return 1; 95 | } 96 | 97 | /* PATTERN : 3 */ 98 | 99 | int isflo1() 100 | { 101 | char *start; 102 | 103 | start = curpos; 104 | digits(); 105 | if (*curpos != '.') 106 | goto fail; 107 | else 108 | curpos++; 109 | if (!isdigit(*curpos)) 110 | goto fail; 111 | digits(); 112 | exponent(); 113 | return 1; 114 | fail: 115 | curpos = start; 116 | return 0; 117 | } 118 | 119 | int isflo2() 120 | { 121 | char *start; 122 | 123 | start = curpos; 124 | if (!isdigit(*curpos)) 125 | goto fail; 126 | digits(); 127 | if (*curpos != '.') 128 | goto fail; 129 | else 130 | curpos++; 131 | digits(); 132 | exponent(); 133 | return 1; 134 | fail: 135 | curpos = start; 136 | return 0; 137 | } 138 | 139 | void exponent() 140 | { 141 | char *start; 142 | 143 | start = curpos; 144 | if ( toupper(*curpos) != 'E') 145 | goto fail; 146 | else 147 | curpos++; 148 | sign(); 149 | if (!isdigit(*curpos)) 150 | goto fail; 151 | digits(); 152 | return; 153 | fail: 154 | curpos = start; 155 | } 156 | 157 | int sonflo() 158 | { 159 | sign(); 160 | return isflo1() || isflo2(); 161 | } 162 | 163 | /* PATTERN : 4 & 6 */ 164 | 165 | int soninteger() 166 | { 167 | char *start; 168 | 169 | start = curpos; 170 | sign(); 171 | if (soffinteger()) 172 | return 1; 173 | curpos = start; 174 | return 0; 175 | } 176 | 177 | int soffinteger() 178 | { 179 | if (!isdigit(*curpos)) 180 | return 0; /* no need to stack start pos */ 181 | digitcnt = 0; 182 | while (isdigit(*curpos)) { 183 | digitcnt++; 184 | curpos++; 185 | } 186 | return 1; 187 | } 188 | 189 | /* PATTERN : 5 */ 190 | 191 | int soffflo() 192 | { 193 | return isflo1() || isflo2(); 194 | } 195 | 196 | /* PATTERN : 7 */ 197 | 198 | int isoctal(c) 199 | { 200 | if ((c >= '0') && (c <= '7')) 201 | return 1; 202 | else 203 | return 0; 204 | } 205 | 206 | int isfpointer() 207 | { 208 | char *start; 209 | 210 | start = curpos; 211 | if (*curpos != '#') 212 | goto fail; 213 | curpos++; 214 | if (!isoctal(*curpos)) 215 | goto fail; 216 | while (((curpos - start) <= 12) && isoctal(*curpos)) 217 | curpos++; 218 | if (*curpos != '#') 219 | goto fail; 220 | curpos++; 221 | return 1; 222 | fail: 223 | curpos = start; 224 | return 0; 225 | } 226 | 227 | /* PATTERN : 8 */ 228 | 229 | int isnonspace() 230 | { 231 | if ((*curpos != ' ') && (*curpos != '\n') && (*curpos != '\t')) 232 | curpos++; 233 | else 234 | return 0; 235 | return 1; 236 | } 237 | 238 | /* PATTERN : 9 */ 239 | 240 | int is_blank() 241 | { 242 | if ((*curpos == ' ') || (*curpos == '\t')) 243 | curpos++; 244 | else 245 | return 0; 246 | return 1; 247 | } 248 | 249 | /* PATTERN : 10 */ 250 | 251 | int iseol() /* comment part added. version 5.2 TY */ 252 | { 253 | if (*curpos == '\n' || *curpos == '%') 254 | return 1; 255 | else 256 | return 0; 257 | } 258 | 259 | /* UTILITIES */ 260 | 261 | void sign() 262 | { 263 | char *start; 264 | start = curpos; 265 | if ((*curpos == '+') || (*curpos == '-')) 266 | curpos++; 267 | if (!isdigit(*curpos)) 268 | curpos = start; 269 | } 270 | 271 | void digits() 272 | { 273 | while (isdigit(*curpos)) 274 | curpos++; 275 | } 276 | 277 | void storetext() /* copies matched text into yytext */ 278 | { 279 | int i; 280 | i = (int) (curpos - lastpos); 281 | strncpy(yytext, lastpos, i); 282 | yytext[i] = 0; 283 | } 284 | 285 | void unput(c) 286 | char c; 287 | { 288 | *(--curpos) = c; 289 | } 290 | 291 | void zycpsunput(c) 292 | char *c; 293 | { 294 | ch1 = curpos; /* curpos plays the same role as yysptr does */ 295 | unput(' '); 296 | unput('"'); 297 | unput(' '); 298 | ch2 = curpos; 299 | while (c != tx) 300 | unput(*(--c)); 301 | return; 302 | } 303 | 304 | int zycpscheck() 305 | { 306 | if (curpos != ch2) { 307 | curpos = ch1; 308 | return 1; 309 | } 310 | curpos = ch1; 311 | return 0; 312 | } 313 | 314 | 315 | /* SLAVE FUNCTIONS */ 316 | 317 | void zysignonoff(x) 318 | int x; 319 | { 320 | if (x) 321 | signflag = 1; 322 | else 323 | signflag = 0; 324 | } 325 | 326 | int yylex() 327 | { 328 | if (*curpos == 0) { 329 | start: 330 | if ((curpos = fgets(input + 100, INPUTBUFLEN - 100, inputf)) == NULL) { 331 | yywrap(); 332 | return EOF; 333 | } /* ver [5.0] .GU */ 334 | #ifndef TESTYYLEX 335 | if (echo.Xvalue != NIL) 336 | zedit(curpos); 337 | #endif 338 | } 339 | delimflag = 0; /* That's the common case */ 340 | match: 341 | lastpos = curpos; 342 | 343 | if (isstring()) { 344 | storetext(); 345 | return Tstring; 346 | } 347 | if (isid()) { 348 | storetext(); 349 | return Tid; 350 | } 351 | if (signflag) { 352 | if (sonflo()) { 353 | storetext(); 354 | return Tfloating; 355 | } 356 | if (soninteger()) { 357 | storetext(); 358 | return digitcnt <= DZ ? Tinteger : Tbig; 359 | } 360 | } else { 361 | if (soffflo()) { 362 | storetext(); 363 | return Tfloating; 364 | } 365 | if (soffinteger()) { 366 | storetext(); 367 | return digitcnt <= DZ ? Tinteger : Tbig; 368 | } 369 | } 370 | if (isfpointer()) { 371 | storetext(); 372 | return Tfpointer; 373 | } 374 | if (iseol()) { 375 | #ifndef TESTYYLEX 376 | if (inputf == stdin && !null(value(&prompt))) { 377 | if (idp(value(&prompt))) 378 | printf("%s", pname(value(&prompt))); 379 | else if (stringp(value(&prompt))) 380 | printf("%s", strbody(value(&prompt))); 381 | } 382 | #endif 383 | goto start; 384 | } 385 | if (isnonspace()) { 386 | delimflag = 1; 387 | storetext(); 388 | return Tid; 389 | } 390 | if (is_blank()) 391 | goto match; 392 | zerror(8); 393 | return 0; /* just for supressing warning - Mar 2009 TY */ 394 | } 395 | 396 | char yych() /* This function is new, will be used by Readch ver [5.0] .GU */ 397 | { 398 | if (*curpos == 0) { 399 | if ((curpos = fgets(input + 100, INPUTBUFLEN - 100, inputf)) == NULL) { 400 | yywrap(); 401 | return EOF; 402 | } /* ver [5.0] .GU */ 403 | #ifndef TESTYYLEX 404 | if (echo.Xvalue != NIL) 405 | zedit(curpos); 406 | #endif 407 | } 408 | return *(curpos++); 409 | } 410 | 411 | 412 | void yywrap() /* was formerly in lisp-zfn.l ... don't know why? */ 413 | { 414 | if (inputf == stdin) { 415 | printf("end of std input file\n"); 416 | exit(0); 417 | } 418 | } 419 | /* The below is new in ver 7.0 */ 420 | 421 | void store_input_buf_save_entry() /* stores current input from inputf */ 422 | { 423 | int i; 424 | for (i = 0 ; i < INPUTSAVETABLESIZE ; i++) 425 | if (input_buf_save_table[i].file == inputf) 426 | goto proceed; 427 | for (i = 0 ; i < INPUTSAVETABLESIZE ; i++) 428 | if (input_buf_save_table[i].file == NULL) 429 | goto proceed; 430 | /* if we are here no empty place in table ..=> issue error */ 431 | zerror(42); 432 | proceed: 433 | input_buf_save_table[i].file = inputf; 434 | input_buf_save_table[i].curpos = curpos; 435 | input_buf_save_table[i].lastpos = lastpos; 436 | memcpy(input_buf_save_table[i].input, input, INPUTBUFLEN); 437 | } 438 | 439 | 440 | void restore_input_buf_save_entry() /* restores current input of inputf */ 441 | { /* if ~exist in table=> no action */ 442 | int i; 443 | for (i = 0 ; i < INPUTSAVETABLESIZE ; i++) 444 | if (input_buf_save_table[i].file == inputf) { 445 | curpos = input_buf_save_table[i].curpos; 446 | lastpos = input_buf_save_table[i].lastpos; 447 | memcpy(input, input_buf_save_table[i].input, INPUTBUFLEN); 448 | return; 449 | } 450 | } 451 | 452 | 453 | int kill_input_buf_save_entry(FILE *f) /* brutally removes current input from f */ 454 | { /* no action if not exist */ 455 | int i; 456 | for (i = 0 ; i < INPUTSAVETABLESIZE ; i++) 457 | if (input_buf_save_table[i].file == f) { 458 | input_buf_save_table[i].file = NULL; 459 | return 1; 460 | } /* only one existence is possible */ 461 | return 0; /* 7.1 now returns the success TY */ 462 | } 463 | 464 | void create_input_buf_save_entry(FILE *f) /* creates a buffer for input 7.1 TY */ 465 | { /* used for keep track of input files */ 466 | int i; 467 | for (i = 0 ; i < INPUTSAVETABLESIZE ; i++) 468 | if (input_buf_save_table[i].file == NULL) { 469 | input_buf_save_table[i].file = f; 470 | input_buf_save_table[i].curpos = ""; 471 | return; 472 | } 473 | zerror(42); /* if we are here no empty place in table ..=> issue error */ 474 | } 475 | -------------------------------------------------------------------------------- /zfnames.l: -------------------------------------------------------------------------------- 1 | void dispstackarg 2 | void dispargs 3 | void errorreturn 4 | void initregs 5 | void kalloc 6 | int main 7 | void yywrap 8 | void zalist 9 | PSEXP zalloc 10 | void zbind 11 | PCHAR zcalloc 12 | int zcollect 13 | void zcompactatom 14 | void zcompactstring 15 | PSEXP zcons 16 | PSEXP zcons1 17 | void zconsc 18 | void zcons2c 19 | void zcons3c 20 | void zdump 21 | void zedit 22 | void zerror 23 | void zescape 24 | PSEXP zfloating 25 | void zgarbage 26 | PPAGE zgetpage 27 | void zinitpages 28 | PSEXP zinteger 29 | void zintern 30 | void zinterrupt 31 | void zmark 32 | PSEXP zoblist 33 | void zpop 34 | void zpopalist 35 | void zpush 36 | PCHAR zsalloc 37 | void zunbind 38 | PSEXP zurlist 39 | void zurwelt 40 | void zysuicide 41 | int ztracearg 42 | int zredefined 43 | void zundefined 44 | void ztraceval 45 | char yych 46 | void zysignonoff 47 | int yylex 48 | PSEXP zbig 49 | long zintval 50 | void zbigint 51 | double zbig2float 52 | void znormalize 53 | void zfnormalize 54 | void zmultiply 55 | void zexpt 56 | void zaddsub 57 | long udivide 58 | void zdivision 59 | --------------------------------------------------------------------------------