1 /*
2 * Copyright (c) 2001 by The XFree86 Project, Inc.
3 *
4 * Permission is hereby granted, free of charge, to any person obtaining a
5 * copy of this software and associated documentation files (the "Software"),
6 * to deal in the Software without restriction, including without limitation
7 * the rights to use, copy, modify, merge, publish, distribute, sublicense,
8 * and/or sell copies of the Software, and to permit persons to whom the
9 * Software is furnished to do so, subject to the following conditions:
10 *
11 * The above copyright notice and this permission notice shall be included in
12 * all copies or substantial portions of the Software.
13 *
14 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
15 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
16 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
17 * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
18 * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
19 * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
20 * SOFTWARE.
21 *
22 * Except as contained in this notice, the name of the XFree86 Project shall
23 * not be used in advertising or otherwise to promote the sale, use or other
24 * dealings in this Software without prior written authorization from the
25 * XFree86 Project.
26 *
27 * Author: Paulo César Pereira de Andrade
28 */
29
30 /* $XFree86: xc/programs/xedit/lisp/lisp.c,v 1.87tsi Exp $ */
31
32 #ifdef HAVE_CONFIG_H
33 # include "config.h"
34 #endif
35
36 #include <stdlib.h>
37 #include <string.h>
38 #ifdef sun
39 #include <strings.h>
40 #endif
41 #include <ctype.h>
42 #include <errno.h>
43 #include <fcntl.h>
44 #include <stdarg.h>
45 #include <signal.h>
46 #include <sys/wait.h>
47
48 #ifndef X_NOT_POSIX
49 #include <unistd.h> /* for sysconf(), and getpagesize() */
50 #endif
51
52 #include "lisp/bytecode.h"
53
54 #include "lisp/read.h"
55 #include "lisp/format.h"
56 #include "lisp/math.h"
57 #include "lisp/hash.h"
58 #include "lisp/package.h"
59 #include "lisp/pathname.h"
60 #include "lisp/regex.h"
61 #include "lisp/require.h"
62 #include "lisp/stream.h"
63 #include "lisp/struct.h"
64 #include "lisp/time.h"
65 #include "lisp/write.h"
66 #include <math.h>
67
68 typedef struct {
69 LispObj **objects;
70 LispObj *freeobj;
71 int nsegs;
72 int nobjs;
73 int nfree;
74 } LispObjSeg;
75
76 /*
77 * Prototypes
78 */
79 static void Lisp__GC(LispObj*, LispObj*);
80 static LispObj *Lisp__New(LispObj*, LispObj*);
81
82 /* run a user function, to be called only by LispEval */
83 static LispObj *LispRunFunMac(LispObj*, LispObj*, int, int);
84
85 /* expands and executes a setf method, to be called only by Lisp_Setf */
86 LispObj *LispRunSetf(LispArgList*, LispObj*, LispObj*, LispObj*);
87 LispObj *LispRunSetfMacro(LispAtom*, LispObj*, LispObj*);
88
89 /* increases storage size for environment */
90 void LispMoreEnvironment(void);
91
92 /* increases storage size for stack of builtin arguments */
93 void LispMoreStack(void);
94
95 /* increases storage size for global variables */
96 void LispMoreGlobals(LispPackage*);
97
98 #ifdef __GNUC__
99 static INLINE LispObj *LispDoGetVar(LispObj*);
100 #endif
101 static INLINE void LispDoAddVar(LispObj*, LispObj*);
102
103 /* Helper for importing symbol(s) functions,
104 * Search for the specified object in the current package */
105 static INLINE LispObj *LispGetVarPack(LispObj*);
106
107 /* create environment for function call */
108 static int LispMakeEnvironment(LispArgList*, LispObj*, LispObj*, int, int);
109
110 /* if not already in keyword package, move atom to keyword package */
111 static LispObj *LispCheckKeyword(LispObj*);
112
113 /* builtin backquote parsing */
114 static LispObj *LispEvalBackquoteObject(LispObj*, int, int);
115 /* used also by the bytecode compiler */
116 LispObj *LispEvalBackquote(LispObj*, int);
117
118 /* create or change object property */
119 void LispSetAtomObjectProperty(LispAtom*, LispObj*);
120 /* remove object property */
121 static void LispRemAtomObjectProperty(LispAtom*);
122
123 /* allocates a new LispProperty for the given atom */
124 static void LispAllocAtomProperty(LispAtom*);
125 /* Increment reference count of atom property */
126 static void LispIncrementAtomReference(LispAtom*);
127 /* Decrement reference count of atom property */
128 static void LispDecrementAtomReference(LispAtom*);
129 /* Removes all atom properties */
130 static void LispRemAtomAllProperties(LispAtom*);
131
132 static LispObj *LispAtomPropertyFunction(LispAtom*, LispObj*, int);
133
134 static INLINE void LispCheckMemLevel(void);
135
136 void LispAllocSeg(LispObjSeg*, int);
137 static INLINE void LispMark(LispObj*);
138
139 /* functions, macros, setf methods, and structure definitions */
140 static INLINE void LispProt(LispObj*);
141
142 static LispObj *LispCheckNeedProtect(LispObj*);
143
144 static void LispSignalHandler(int);
145
146 /*
147 * Initialization
148 */
149 LispMac lisp__data;
150
151 static LispObj lispunbound = {LispNil_t};
152 LispObj *UNBOUND = &lispunbound;
153
154 static volatile int lisp__disable_int;
155 static volatile int lisp__interrupted;
156
157 LispObj *Okey, *Orest, *Ooptional, *Oaux, *Olambda;
158
159 Atom_id Snil, St;
160 Atom_id Saux, Skey, Soptional, Srest;
161 Atom_id Satom, Ssymbol, Sinteger, Scharacter, Sstring, Slist,
162 Scons, Svector, Sarray, Sstruct, Skeyword, Sfunction, Spathname,
163 Srational, Sfloat, Scomplex, Sopaque, Sdefault;
164
165 LispObj *Oformat, *Kunspecific;
166 LispObj *Oexpand_setf_method;
167
168 static LispProperty noproperty;
169 LispProperty *NOPROPERTY = &noproperty;
170 static int segsize, minfree;
171 int pagesize, gcpro;
172
173 static LispObjSeg objseg = {NULL, NIL};
174 static LispObjSeg atomseg = {NULL, NIL};
175
176 int LispArgList_t;
177
178 LispFile *Stdout, *Stdin, *Stderr;
179
180 static LispBuiltin lispbuiltins[] = {
181 {LispFunction, Lisp_Mul, "* &rest numbers"},
182 {LispFunction, Lisp_Plus, "+ &rest numbers"},
183 {LispFunction, Lisp_Minus, "- number &rest more-numbers"},
184 {LispFunction, Lisp_Div, "/ number &rest more-numbers"},
185 {LispFunction, Lisp_OnePlus, "1+ number"},
186 {LispFunction, Lisp_OneMinus, "1- number"},
187 {LispFunction, Lisp_Less, "< number &rest more-numbers"},
188 {LispFunction, Lisp_LessEqual, "<= number &rest more-numbers"},
189 {LispFunction, Lisp_Equal_, "= number &rest more-numbers"},
190 {LispFunction, Lisp_Greater, "> number &rest more-numbers"},
191 {LispFunction, Lisp_GreaterEqual, ">= number &rest more-numbers"},
192 {LispFunction, Lisp_NotEqual, "/= number &rest more-numbers"},
193 {LispFunction, Lisp_Max, "max number &rest more-numbers"},
194 {LispFunction, Lisp_Min, "min number &rest more-numbers"},
195 {LispFunction, Lisp_Abs, "abs number"},
196 {LispFunction, Lisp_Acons, "acons key datum alist"},
197 {LispFunction, Lisp_Adjoin, "adjoin item list &key key test test-not"},
198 {LispFunction, Lisp_AlphaCharP, "alpha-char-p char"},
199 {LispMacro, Lisp_And, "and &rest args", 1, 0, Com_And},
200 {LispFunction, Lisp_Append, "append &rest lists"},
201 {LispFunction, Lisp_Apply, "apply function arg &rest more-args", 1},
202 {LispFunction, Lisp_Aref, "aref array &rest subscripts"},
203 {LispFunction, Lisp_Assoc, "assoc item list &key test test-not key"},
204 {LispFunction, Lisp_AssocIf, "assoc-if predicate list &key key"},
205 {LispFunction, Lisp_AssocIfNot, "assoc-if-not predicate list &key key"},
206 {LispFunction, Lisp_Atom, "atom object"},
207 {LispMacro, Lisp_Block, "block name &rest body", 1, 0, Com_Block},
208 {LispFunction, Lisp_BothCaseP, "both-case-p character"},
209 {LispFunction, Lisp_Boundp, "boundp symbol"},
210 {LispFunction, Lisp_Butlast, "butlast list &optional count"},
211 {LispFunction, Lisp_Nbutlast, "nbutlast list &optional count"},
212 {LispFunction, Lisp_Car, "car list", 0, 0, Com_C_r},
213 {LispFunction, Lisp_Car, "first list", 0, 0, Com_C_r},
214 {LispMacro, Lisp_Case, "case keyform &rest body"},
215 {LispMacro, Lisp_Catch, "catch tag &rest body", 1},
216 {LispFunction, Lisp_Cdr, "cdr list", 0, 0, Com_C_r},
217 {LispFunction, Lisp_Cdr, "rest list", 0, 0, Com_C_r},
218 {LispFunction, Lisp_Ceiling, "ceiling number &optional divisor", 1},
219 {LispFunction, Lisp_Fceiling, "fceiling number &optional divisor", 1},
220 {LispFunction, Lisp_Char, "char string index"},
221 {LispFunction, Lisp_Char, "schar simple-string index"},
222 {LispFunction, Lisp_CharLess, "char< character &rest more-characters"},
223 {LispFunction, Lisp_CharLessEqual, "char<= character &rest more-characters"},
224 {LispFunction, Lisp_CharEqual_, "char= character &rest more-characters"},
225 {LispFunction, Lisp_CharGreater, "char> character &rest more-characters"},
226 {LispFunction, Lisp_CharGreaterEqual, "char>= character &rest more-characters"},
227 {LispFunction, Lisp_CharNotEqual_, "char/= character &rest more-characters"},
228 {LispFunction, Lisp_CharLessp, "char-lessp character &rest more-characters"},
229 {LispFunction, Lisp_CharNotGreaterp, "char-not-greaterp character &rest more-characters"},
230 {LispFunction, Lisp_CharEqual, "char-equal character &rest more-characters"},
231 {LispFunction, Lisp_CharGreaterp, "char-greaterp character &rest more-characters"},
232 {LispFunction, Lisp_CharNotLessp, "char-not-lessp character &rest more-characters"},
233 {LispFunction, Lisp_CharNotEqual, "char-not-equal character &rest more-characters"},
234 {LispFunction, Lisp_CharDowncase, "char-downcase character"},
235 {LispFunction, Lisp_CharInt, "char-code character"},
236 {LispFunction, Lisp_CharInt, "char-int character"},
237 {LispFunction, Lisp_CharUpcase, "char-upcase character"},
238 {LispFunction, Lisp_Character, "character object"},
239 {LispFunction, Lisp_Characterp, "characterp object"},
240 {LispFunction, Lisp_Clrhash, "clrhash hash-table"},
241 {LispFunction, Lisp_IntChar, "code-char integer"},
242 {LispFunction, Lisp_Coerce, "coerce object result-type"},
243 {LispFunction, Lisp_Compile, "compile name &optional definition", 1},
244 {LispFunction, Lisp_Complex, "complex realpart &optional imagpart"},
245 {LispMacro, Lisp_Cond, "cond &rest body", 0, 0, Com_Cond},
246 {LispFunction, Lisp_Cons, "cons car cdr", 0, 0, Com_Cons},
247 {LispFunction, Lisp_Consp, "consp object", 0, 0, Com_Consp},
248 {LispFunction, Lisp_Constantp, "constantp form &optional environment"},
249 {LispFunction, Lisp_Conjugate, "conjugate number"},
250 {LispFunction, Lisp_Complexp, "complexp object"},
251 {LispFunction, Lisp_CopyAlist, "copy-alist list"},
252 {LispFunction, Lisp_CopyList, "copy-list list"},
253 {LispFunction, Lisp_CopyTree, "copy-tree list"},
254 {LispFunction, Lisp_Close, "close stream &key abort"},
255 {LispFunction, Lisp_C_r, "caar list", 0, 0, Com_C_r},
256 {LispFunction, Lisp_C_r, "cadr list", 0, 0, Com_C_r},
257 {LispFunction, Lisp_C_r, "cdar list", 0, 0, Com_C_r},
258 {LispFunction, Lisp_C_r, "cddr list", 0, 0, Com_C_r},
259 {LispFunction, Lisp_C_r, "caaar list", 0, 0, Com_C_r},
260 {LispFunction, Lisp_C_r, "caadr list", 0, 0, Com_C_r},
261 {LispFunction, Lisp_C_r, "cadar list", 0, 0, Com_C_r},
262 {LispFunction, Lisp_C_r, "caddr list", 0, 0, Com_C_r},
263 {LispFunction, Lisp_C_r, "cdaar list", 0, 0, Com_C_r},
264 {LispFunction, Lisp_C_r, "cdadr list", 0, 0, Com_C_r},
265 {LispFunction, Lisp_C_r, "cddar list", 0, 0, Com_C_r},
266 {LispFunction, Lisp_C_r, "cdddr list", 0, 0, Com_C_r},
267 {LispFunction, Lisp_C_r, "caaaar list", 0, 0, Com_C_r},
268 {LispFunction, Lisp_C_r, "caaadr list", 0, 0, Com_C_r},
269 {LispFunction, Lisp_C_r, "caadar list", 0, 0, Com_C_r},
270 {LispFunction, Lisp_C_r, "caaddr list", 0, 0, Com_C_r},
271 {LispFunction, Lisp_C_r, "cadaar list", 0, 0, Com_C_r},
272 {LispFunction, Lisp_C_r, "cadadr list", 0, 0, Com_C_r},
273 {LispFunction, Lisp_C_r, "caddar list", 0, 0, Com_C_r},
274 {LispFunction, Lisp_C_r, "cadddr list", 0, 0, Com_C_r},
275 {LispFunction, Lisp_C_r, "cdaaar list", 0, 0, Com_C_r},
276 {LispFunction, Lisp_C_r, "cdaadr list", 0, 0, Com_C_r},
277 {LispFunction, Lisp_C_r, "cdadar list", 0, 0, Com_C_r},
278 {LispFunction, Lisp_C_r, "cdaddr list", 0, 0, Com_C_r},
279 {LispFunction, Lisp_C_r, "cddaar list", 0, 0, Com_C_r},
280 {LispFunction, Lisp_C_r, "cddadr list", 0, 0, Com_C_r},
281 {LispFunction, Lisp_C_r, "cdddar list", 0, 0, Com_C_r},
282 {LispFunction, Lisp_C_r, "cddddr list", 0, 0, Com_C_r},
283 {LispMacro, Lisp_Decf, "decf place &optional delta"},
284 {LispMacro, Lisp_Defconstant, "defconstant name initial-value &optional documentation"},
285 {LispMacro, Lisp_Defmacro, "defmacro name lambda-list &rest body"},
286 {LispMacro, Lisp_Defstruct, "defstruct name &rest description"},
287 {LispMacro, Lisp_Defun, "defun name lambda-list &rest body"},
288 {LispMacro, Lisp_Defsetf, "defsetf function lambda-list &rest body"},
289 {LispMacro, Lisp_Defparameter, "defparameter name initial-value &optional documentation"},
290 {LispMacro, Lisp_Defvar, "defvar name &optional initial-value documentation"},
291 {LispFunction, Lisp_Delete, "delete item sequence &key from-end test test-not start end count key"},
292 {LispFunction, Lisp_DeleteDuplicates, "delete-duplicates sequence &key from-end test test-not start end key"},
293 {LispFunction, Lisp_DeleteIf, "delete-if predicate sequence &key from-end start end count key"},
294 {LispFunction, Lisp_DeleteIfNot, "delete-if-not predicate sequence &key from-end start end count key"},
295 {LispFunction, Lisp_DeleteFile, "delete-file filename"},
296 {LispFunction, Lisp_Denominator, "denominator rational"},
297 {LispFunction, Lisp_DigitChar, "digit-char weight &optional radix"},
298 {LispFunction, Lisp_DigitCharP, "digit-char-p character &optional radix"},
299 {LispFunction, Lisp_Directory, "directory pathname &key all if-cannot-read"},
300 {LispFunction, Lisp_DirectoryNamestring, "directory-namestring pathname"},
301 {LispFunction, Lisp_Disassemble, "disassemble function"},
302 {LispMacro, Lisp_Do, "do init test &rest body"},
303 {LispMacro, Lisp_DoP, "do* init test &rest body"},
304 {LispFunction, Lisp_Documentation, "documentation symbol type"},
305 {LispMacro, Lisp_DoList, "dolist init &rest body", 0, 0, Com_Dolist},
306 {LispMacro, Lisp_DoTimes, "dotimes init &rest body"},
307 {LispMacro, Lisp_DoAllSymbols, "do-all-symbols init &rest body"},
308 {LispMacro, Lisp_DoExternalSymbols, "do-external-symbols init &rest body"},
309 {LispMacro, Lisp_DoSymbols, "do-symbols init &rest body"},
310 {LispFunction, Lisp_Elt, "elt sequence index"},
311 {LispFunction, Lisp_Endp, "endp object"},
312 {LispFunction, Lisp_EnoughNamestring, "enough-namestring pathname &optional defaults"},
313 {LispFunction, Lisp_Eq, "eq left right", 0, 0, Com_Eq},
314 {LispFunction, Lisp_Eql, "eql left right", 0, 0, Com_Eq},
315 {LispFunction, Lisp_Equal, "equal left right", 0, 0, Com_Eq},
316 {LispFunction, Lisp_Equalp, "equalp left right", 0, 0, Com_Eq},
317 {LispFunction, Lisp_Error, "error control-string &rest arguments"},
318 {LispFunction, Lisp_Evenp, "evenp integer"},
319 {LispFunction, Lisp_Export, "export symbols &optional package"},
320 {LispFunction, Lisp_Eval, "eval form"},
321 {LispFunction, Lisp_Every, "every predicate sequence &rest more-sequences"},
322 {LispFunction, Lisp_Some, "some predicate sequence &rest more-sequences"},
323 {LispFunction, Lisp_Notevery, "notevery predicate sequence &rest more-sequences"},
324 {LispFunction, Lisp_Notany, "notany predicate sequence &rest more-sequences"},
325 {LispFunction, Lisp_Fboundp, "fboundp symbol"},
326 {LispFunction, Lisp_Find, "find item sequence &key from-end test test-not start end key"},
327 {LispFunction, Lisp_FindIf, "find-if predicate sequence &key from-end start end key"},
328 {LispFunction, Lisp_FindIfNot, "find-if-not predicate sequence &key from-end start end key"},
329 {LispFunction, Lisp_FileNamestring, "file-namestring pathname"},
330 {LispFunction, Lisp_Fill, "fill sequence item &key start end"},
331 {LispFunction, Lisp_FindAllSymbols, "find-all-symbols string-or-symbol"},
332 {LispFunction, Lisp_FindSymbol, "find-symbol string &optional package", 1},
333 {LispFunction, Lisp_FindPackage, "find-package name"},
334 {LispFunction, Lisp_Float, "float number &optional other"},
335 {LispFunction, Lisp_Floatp, "floatp object"},
336 {LispFunction, Lisp_Floor, "floor number &optional divisor", 1},
337 {LispFunction, Lisp_Ffloor, "ffloor number &optional divisor", 1},
338 {LispFunction, Lisp_Fmakunbound, "fmakunbound symbol"},
339 {LispFunction, Lisp_Format, "format destination control-string &rest arguments"},
340 {LispFunction, Lisp_FreshLine, "fresh-line &optional output-stream"},
341 {LispFunction, Lisp_Funcall, "funcall function &rest arguments", 1},
342 {LispFunction, Lisp_Functionp, "functionp object"},
343 {LispFunction, Lisp_Gc, "gc &optional car cdr"},
344 {LispFunction, Lisp_Gcd, "gcd &rest integers"},
345 {LispFunction, Lisp_Gensym, "gensym &optional arg"},
346 {LispFunction, Lisp_Get, "get symbol indicator &optional default"},
347 {LispFunction, Lisp_Gethash, "gethash key hash-table &optional default", 1},
348 {LispMacro, Lisp_Go, "go tag", 0, 0, Com_Go},
349 {LispFunction, Lisp_GraphicCharP, "graphic-char-p char"},
350 {LispFunction, Lisp_HashTableP, "hash-table-p object"},
351 {LispFunction, Lisp_HashTableCount, "hash-table-count hash-table"},
352 {LispFunction, Lisp_HashTableRehashSize, "hash-table-rehash-size hash-table"},
353 {LispFunction, Lisp_HashTableRehashThreshold, "hash-table-rehash-threshold hash-table"},
354 {LispFunction, Lisp_HashTableSize, "hash-table-size hash-table"},
355 {LispFunction, Lisp_HashTableTest, "hash-table-test hash-table"},
356 {LispFunction, Lisp_HostNamestring, "host-namestring pathname"},
357 {LispMacro, Lisp_If, "if test then &optional else", 0, 0, Com_If},
358 {LispMacro, Lisp_IgnoreErrors, "ignore-errors &rest body", 1},
359 {LispFunction, Lisp_Imagpart, "imagpart number"},
360 {LispMacro, Lisp_InPackage, "in-package name"},
361 {LispMacro, Lisp_Incf, "incf place &optional delta"},
362 {LispFunction, Lisp_Import, "import symbols &optional package"},
363 {LispFunction, Lisp_InputStreamP, "input-stream-p stream"},
364 {LispFunction, Lisp_IntChar, "int-char integer"},
365 {LispFunction, Lisp_Integerp, "integerp object"},
366 {LispFunction, Lisp_Intern, "intern string &optional package", 1},
367 {LispFunction, Lisp_Intersection, "intersection list1 list2 &key test test-not key"},
368 {LispFunction, Lisp_Nintersection, "nintersection list1 list2 &key test test-not key"},
369 {LispFunction, Lisp_Isqrt, "isqrt natural"},
370 {LispFunction, Lisp_Keywordp, "keywordp object"},
371 {LispFunction, Lisp_Last, "last list &optional count", 0, 0, Com_Last},
372 {LispMacro, Lisp_Lambda, "lambda lambda-list &rest body"},
373 {LispFunction, Lisp_Lcm, "lcm &rest integers"},
374 {LispFunction, Lisp_Length, "length sequence", 0, 0, Com_Length},
375 {LispMacro, Lisp_Let, "let init &rest body", 1, 0, Com_Let},
376 {LispMacro, Lisp_LetP, "let* init &rest body", 1, 0, Com_Letx},
377 {LispFunction, Lisp_ListP, "list* object &rest more-objects"},
378 {LispFunction, Lisp_ListAllPackages, "list-all-packages"},
379 {LispFunction, Lisp_List, "list &rest args"},
380 {LispFunction, Lisp_ListLength, "list-length list"},
381 {LispFunction, Lisp_Listp, "listp object", 0, 0, Com_Listp},
382 {LispFunction, Lisp_Listen, "listen &optional input-stream"},
383 {LispFunction, Lisp_Load, "load filename &key verbose print if-does-not-exist"},
384 {LispFunction, Lisp_Logand, "logand &rest integers"},
385 {LispFunction, Lisp_Logeqv, "logeqv &rest integers"},
386 {LispFunction, Lisp_Logior, "logior &rest integers"},
387 {LispFunction, Lisp_Lognot, "lognot integer"},
388 {LispFunction, Lisp_Logxor, "logxor &rest integers"},
389 {LispMacro, Lisp_Loop, "loop &rest body", 0, 0, Com_Loop},
390 {LispFunction, Lisp_LowerCaseP, "lower-case-p character"},
391 {LispFunction, Lisp_MakeArray, "make-array dimensions &key element-type initial-element initial-contents adjustable fill-pointer displaced-to displaced-index-offset"},
392 {LispFunction, Lisp_MakeHashTable, "make-hash-table &key test size rehash-size rehash-threshold initial-contents"},
393 {LispFunction, Lisp_MakeList, "make-list size &key initial-element"},
394 {LispFunction, Lisp_MakePackage, "make-package package-name &key nicknames use"},
395 {LispFunction, Lisp_MakePathname, "make-pathname &key host device directory name type version defaults"},
396 {LispFunction, Lisp_MakeString, "make-string size &key initial-element element-type"},
397 {LispFunction, Lisp_MakeSymbol, "make-symbol name"},
398 {LispFunction, Lisp_MakeStringInputStream, "make-string-input-stream string &optional start end"},
399 {LispFunction, Lisp_MakeStringOutputStream, "make-string-output-stream &key element-type"},
400 {LispFunction, Lisp_GetOutputStreamString, "get-output-stream-string string-output-stream"},
401 {LispFunction, Lisp_Makunbound, "makunbound symbol"},
402 {LispFunction, Lisp_Mapc, "mapc function list &rest more-lists"},
403 {LispFunction, Lisp_Mapcar, "mapcar function list &rest more-lists"},
404 {LispFunction, Lisp_Mapcan, "mapcan function list &rest more-lists"},
405 {LispFunction, Lisp_Maphash, "maphash function hash-table"},
406 {LispFunction, Lisp_Mapl, "mapl function list &rest more-lists"},
407 {LispFunction, Lisp_Maplist, "maplist function list &rest more-lists"},
408 {LispFunction, Lisp_Mapcon, "mapcon function list &rest more-lists"},
409 {LispFunction, Lisp_Member, "member item list &key test test-not key"},
410 {LispFunction, Lisp_MemberIf, "member-if predicate list &key key"},
411 {LispFunction, Lisp_MemberIfNot, "member-if-not predicate list &key key"},
412 {LispFunction, Lisp_Minusp, "minusp number"},
413 {LispFunction, Lisp_Mod, "mod number divisor"},
414 {LispMacro, Lisp_MultipleValueBind, "multiple-value-bind symbols values &rest body"},
415 {LispMacro, Lisp_MultipleValueCall, "multiple-value-call function &rest form", 1},
416 {LispMacro, Lisp_MultipleValueProg1, "multiple-value-prog1 first-form &rest form", 1},
417 {LispMacro, Lisp_MultipleValueList, "multiple-value-list form"},
418 {LispMacro, Lisp_MultipleValueSetq, "multiple-value-setq symbols form"},
419 {LispFunction, Lisp_Nconc, "nconc &rest lists"},
420 {LispFunction, Lisp_Nreverse, "nreverse sequence"},
421 {LispFunction, Lisp_NsetDifference, "nset-difference list1 list2 &key test test-not key"},
422 {LispFunction, Lisp_Nsubstitute, "nsubstitute newitem olditem sequence &key from-end test test-not start end count key"},
423 {LispFunction, Lisp_NsubstituteIf, "nsubstitute-if newitem test sequence &key from-end start end count key"},
424 {LispFunction, Lisp_NsubstituteIfNot, "nsubstitute-if-not newitem test sequence &key from-end start end count key"},
425 {LispFunction, Lisp_Nth, "nth index list"},
426 {LispFunction, Lisp_Nthcdr, "nthcdr index list", 0, 0, Com_Nthcdr},
427 {LispMacro, Lisp_NthValue, "nth-value index form"},
428 {LispFunction, Lisp_Numerator, "numerator rational"},
429 {LispFunction, Lisp_Namestring, "namestring pathname"},
430 {LispFunction, Lisp_Null, "not arg", 0, 0, Com_Null},
431 {LispFunction, Lisp_Null, "null list", 0, 0, Com_Null},
432 {LispFunction, Lisp_Numberp, "numberp object", 0, 0, Com_Numberp},
433 {LispFunction, Lisp_Oddp, "oddp integer"},
434 {LispFunction, Lisp_Open, "open filename &key direction element-type if-exists if-does-not-exist external-format"},
435 {LispFunction, Lisp_OpenStreamP, "open-stream-p stream"},
436 {LispMacro, Lisp_Or, "or &rest args", 1, 0, Com_Or},
437 {LispFunction, Lisp_OutputStreamP, "output-stream-p stream"},
438 {LispFunction, Lisp_Packagep, "packagep object"},
439 {LispFunction, Lisp_PackageName, "package-name package"},
440 {LispFunction, Lisp_PackageNicknames, "package-nicknames package"},
441 {LispFunction, Lisp_PackageUseList, "package-use-list package"},
442 {LispFunction, Lisp_PackageUsedByList, "package-used-by-list package"},
443 {LispFunction, Lisp_Pairlis, "pairlis key data &optional alist"},
444 {LispFunction, Lisp_ParseInteger, "parse-integer string &key start end radix junk-allowed", 1},
445 {LispFunction, Lisp_ParseNamestring, "parse-namestring object &optional host defaults &key start end junk-allowed", 1},
446 {LispFunction, Lisp_PathnameHost, "pathname-host pathname"},
447 {LispFunction, Lisp_PathnameDevice, "pathname-device pathname"},
448 {LispFunction, Lisp_PathnameDirectory, "pathname-directory pathname"},
449 {LispFunction, Lisp_PathnameName, "pathname-name pathname"},
450 {LispFunction, Lisp_PathnameType, "pathname-type pathname"},
451 {LispFunction, Lisp_PathnameVersion, "pathname-version pathname"},
452 {LispFunction, Lisp_Pathnamep, "pathnamep object"},
453 {LispFunction, Lisp_Plusp, "plusp number"},
454 {LispMacro, Lisp_Pop, "pop place"},
455 {LispFunction, Lisp_Position, "position item sequence &key from-end test test-not start end key"},
456 {LispFunction, Lisp_PositionIf, "position-if predicate sequence &key from-end start end key"},
457 {LispFunction, Lisp_PositionIfNot, "position-if-not predicate sequence &key from-end start end key"},
458 {LispFunction, Lisp_Prin1, "prin1 object &optional output-stream"},
459 {LispFunction, Lisp_Princ, "princ object &optional output-stream"},
460 {LispFunction, Lisp_Print, "print object &optional output-stream"},
461 {LispFunction, Lisp_ProbeFile, "probe-file pathname"},
462 {LispFunction, Lisp_Proclaim, "proclaim declaration"},
463 {LispMacro, Lisp_Prog1, "prog1 first &rest body"},
464 {LispMacro, Lisp_Prog2, "prog2 first second &rest body"},
465 {LispMacro, Lisp_Progn, "progn &rest body", 1, 0, Com_Progn},
466 {LispMacro, Lisp_Progv, "progv symbols values &rest body", 1},
467 {LispFunction, Lisp_Provide, "provide module"},
468 {LispMacro, Lisp_Push, "push item place"},
469 {LispMacro, Lisp_Pushnew, "pushnew item place &key key test test-not"},
470 {LispFunction, Lisp_Quit, "quit &optional status"},
471 {LispMacro, Lisp_Quote, "quote object"},
472 {LispFunction, Lisp_Rational, "rational number"},
473 {LispFunction, Lisp_Rationalp, "rationalp object"},
474 {LispFunction, Lisp_Read, "read &optional input-stream eof-error-p eof-value recursive-p"},
475 {LispFunction, Lisp_ReadChar, "read-char &optional input-stream eof-error-p eof-value recursive-p"},
476 {LispFunction, Lisp_ReadCharNoHang, "read-char-no-hang &optional input-stream eof-error-p eof-value recursive-p"},
477 {LispFunction, Lisp_ReadLine, "read-line &optional input-stream eof-error-p eof-value recursive-p", 1},
478 {LispFunction, Lisp_Realpart, "realpart number"},
479 {LispFunction, Lisp_Replace, "replace sequence1 sequence2 &key start1 end1 start2 end2"},
480 {LispFunction, Lisp_ReadFromString, "read-from-string string &optional eof-error-p eof-value &key start end preserve-whitespace", 1},
481 {LispFunction, Lisp_Require, "require module &optional pathname"},
482 {LispFunction, Lisp_Rem, "rem number divisor"},
483 {LispFunction, Lisp_Remhash, "remhash key hash-table"},
484 {LispFunction, Lisp_Remove, "remove item sequence &key from-end test test-not start end count key"},
485 {LispFunction, Lisp_RemoveDuplicates, "remove-duplicates sequence &key from-end test test-not start end key"},
486 {LispFunction, Lisp_RemoveIf, "remove-if predicate sequence &key from-end start end count key"},
487 {LispFunction, Lisp_RemoveIfNot, "remove-if-not predicate sequence &key from-end start end count key"},
488 {LispFunction, Lisp_Remprop, "remprop symbol indicator"},
489 {LispFunction, Lisp_RenameFile, "rename-file filename new-name", 1},
490 {LispMacro, Lisp_Return, "return &optional result", 1, 0, Com_Return},
491 {LispMacro, Lisp_ReturnFrom, "return-from name &optional result", 1, 0, Com_ReturnFrom},
492 {LispFunction, Lisp_Reverse, "reverse sequence"},
493 {LispFunction, Lisp_Round, "round number &optional divisor", 1},
494 {LispFunction, Lisp_Fround, "fround number &optional divisor", 1},
495 {LispFunction, Lisp_Rplaca, "rplaca place value", 0, 0, Com_Rplac_},
496 {LispFunction, Lisp_Rplacd, "rplacd place value", 0, 0, Com_Rplac_},
497 {LispFunction, Lisp_Search, "search sequence1 sequence2 &key from-end test test-not key start1 start2 end1 end2"},
498 {LispFunction, Lisp_Set, "set symbol value"},
499 {LispFunction, Lisp_SetDifference, "set-difference list1 list2 &key test test-not key"},
500 {LispFunction, Lisp_SetExclusiveOr, "set-exclusive-or list1 list2 &key test test-not key"},
501 {LispFunction, Lisp_NsetExclusiveOr, "nset-exclusive-or list1 list2 &key test test-not key"},
502 {LispMacro, Lisp_Setf, "setf &rest form"},
503 {LispMacro, Lisp_Psetf, "psetf &rest form"},
504 {LispMacro, Lisp_SetQ, "setq &rest form", 0, 0, Com_Setq},
505 {LispMacro, Lisp_Psetq, "psetq &rest form"},
506 {LispFunction, Lisp_Sleep, "sleep seconds"},
507 {LispFunction, Lisp_Sort, "sort sequence predicate &key key"},
508 {LispFunction, Lisp_Sqrt, "sqrt number"},
509 {LispFunction, Lisp_Elt, "svref sequence index"},
510 {LispFunction, Lisp_Sort, "stable-sort sequence predicate &key key"},
511 {LispFunction, Lisp_Streamp, "streamp object"},
512 {LispFunction, Lisp_String, "string object"},
513 {LispFunction, Lisp_Stringp, "stringp object"},
514 {LispFunction, Lisp_StringEqual_, "string= string1 string2 &key start1 end1 start2 end2"},
515 {LispFunction, Lisp_StringLess, "string< string1 string2 &key start1 end1 start2 end2"},
516 {LispFunction, Lisp_StringGreater, "string> string1 string2 &key start1 end1 start2 end2"},
517 {LispFunction, Lisp_StringLessEqual, "string<= string1 string2 &key start1 end1 start2 end2"},
518 {LispFunction, Lisp_StringGreaterEqual, "string>= string1 string2 &key start1 end1 start2 end2"},
519 {LispFunction, Lisp_StringNotEqual_, "string/= string1 string2 &key start1 end1 start2 end2"},
520 {LispFunction, Lisp_StringConcat, "string-concat &rest strings"},
521 {LispFunction, Lisp_StringEqual, "string-equal string1 string2 &key start1 end1 start2 end2"},
522 {LispFunction, Lisp_StringGreaterp, "string-greaterp string1 string2 &key start1 end1 start2 end2"},
523 {LispFunction, Lisp_StringNotEqual, "string-not-equal string1 string2 &key start1 end1 start2 end2"},
524 {LispFunction, Lisp_StringNotGreaterp, "string-not-greaterp string1 string2 &key start1 end1 start2 end2"},
525 {LispFunction, Lisp_StringNotLessp, "string-not-lessp string1 string2 &key start1 end1 start2 end2"},
526 {LispFunction, Lisp_StringLessp, "string-lessp string1 string2 &key start1 end1 start2 end2"},
527 {LispFunction, Lisp_StringTrim, "string-trim character-bag string"},
528 {LispFunction, Lisp_StringLeftTrim, "string-left-trim character-bag string"},
529 {LispFunction, Lisp_StringRightTrim, "string-right-trim character-bag string"},
530 {LispFunction, Lisp_StringUpcase, "string-upcase string &key start end"},
531 {LispFunction, Lisp_NstringUpcase, "nstring-upcase string &key start end"},
532 {LispFunction, Lisp_StringDowncase, "string-downcase string &key start end"},
533 {LispFunction, Lisp_NstringDowncase, "nstring-downcase string &key start end"},
534 {LispFunction, Lisp_StringCapitalize, "string-capitalize string &key start end"},
535 {LispFunction, Lisp_NstringCapitalize, "nstring-capitalize string &key start end"},
536 {LispFunction, Lisp_Subseq, "subseq sequence start &optional end"},
537 {LispFunction, Lisp_Subsetp, "subsetp list1 list2 &key test test-not key"},
538 {LispFunction, Lisp_Substitute, "substitute newitem olditem sequence &key from-end test test-not start end count key"},
539 {LispFunction, Lisp_SubstituteIf, "substitute-if newitem test sequence &key from-end start end count key"},
540 {LispFunction, Lisp_SubstituteIfNot, "substitute-if-not newitem test sequence &key from-end start end count key"},
541 {LispFunction, Lisp_SymbolFunction, "symbol-function symbol"},
542 {LispFunction, Lisp_SymbolName, "symbol-name symbol"},
543 {LispFunction, Lisp_Symbolp, "symbolp object"},
544 {LispFunction, Lisp_SymbolPlist, "symbol-plist symbol"},
545 {LispFunction, Lisp_SymbolPackage, "symbol-package symbol"},
546 {LispFunction, Lisp_SymbolValue, "symbol-value symbol"},
547 {LispMacro, Lisp_Tagbody, "tagbody &rest body", 0, 0, Com_Tagbody},
548 {LispFunction, Lisp_Terpri, "terpri &optional output-stream"},
549 {LispFunction, Lisp_Typep, "typep object type"},
550 {LispMacro, Lisp_The, "the value-type form"},
551 {LispMacro, Lisp_Throw, "throw tag result", 1},
552 {LispMacro, Lisp_Time, "time form"},
553 {LispFunction, Lisp_Truename, "truename pathname"},
554 {LispFunction, Lisp_TreeEqual, "tree-equal tree-1 tree-2 &key test test-not"},
555 {LispFunction, Lisp_Truncate, "truncate number &optional divisor", 1},
556 {LispFunction, Lisp_Ftruncate, "ftruncate number &optional divisor", 1},
557 {LispFunction, Lisp_Unexport, "unexport symbols &optional package"},
558 {LispFunction, Lisp_Union, "union list1 list2 &key test test-not key"},
559 {LispFunction, Lisp_Nunion, "nunion list1 list2 &key test test-not key"},
560 {LispMacro, Lisp_Unless, "unless test &rest body", 1, 0, Com_Unless},
561 {LispFunction, Lisp_UserHomedirPathname, "user-homedir-pathname &optional host"},
562 {LispMacro, Lisp_UnwindProtect, "unwind-protect protect &rest cleanup"},
563 {LispFunction, Lisp_UpperCaseP, "upper-case-p character"},
564 {LispFunction, Lisp_Values, "values &rest objects", 1},
565 {LispFunction, Lisp_ValuesList, "values-list list", 1},
566 {LispFunction, Lisp_Vector, "vector &rest objects"},
567 {LispMacro, Lisp_When, "when test &rest body", 1, 0, Com_When},
568 {LispFunction, Lisp_Write, " write object &key case circle escape length level lines pretty readably right-margin stream"},
569 {LispFunction, Lisp_WriteChar, "write-char string &optional output-stream"},
570 {LispFunction, Lisp_WriteLine, "write-line string &optional output-stream &key start end"},
571 {LispFunction, Lisp_WriteString, "write-string string &optional output-stream &key start end"},
572 {LispFunction, Lisp_XeditCharStore, "lisp::char-store string index value", 0, 1},
573 {LispFunction, Lisp_XeditEltStore, "lisp::elt-store sequence index value", 0, 1},
574 {LispFunction, Lisp_XeditMakeStruct, "lisp::make-struct atom &rest init", 0, 1},
575 {LispFunction, Lisp_XeditPut, " lisp::put symbol indicator value", 0, 1},
576 {LispFunction, Lisp_XeditPuthash, "lisp::puthash key hash-table value", 0, 1},
577 {LispFunction, Lisp_XeditSetSymbolPlist, "lisp::set-symbol-plist symbol list", 0, 1},
578 {LispFunction, Lisp_XeditStructAccess, "lisp::struct-access atom struct", 0, 1},
579 {LispFunction, Lisp_XeditStructType, "lisp::struct-type atom struct", 0, 1},
580 {LispFunction, Lisp_XeditStructStore, "lisp::struct-store atom struct value", 0, 1},
581 {LispFunction, Lisp_XeditVectorStore, "lisp::vector-store array &rest values", 0, 1},
582 {LispFunction, Lisp_XeditDocumentationStore, "lisp::documentation-store symbol type string", 0, 1},
583 {LispFunction, Lisp_Zerop, "zerop number"},
584 };
585
586 static LispBuiltin extbuiltins[] = {
587 {LispFunction, Lisp_Getenv, "getenv name"},
588 {LispFunction, Lisp_MakePipe, "make-pipe command-line &key direction element-type external-format"},
589 {LispFunction, Lisp_PipeBroken, "pipe-broken pipe-stream"},
590 {LispFunction, Lisp_PipeErrorStream, "pipe-error-stream pipe-stream"},
591 {LispFunction, Lisp_PipeInputDescriptor, "pipe-input-descriptor pipe-stream"},
592 {LispFunction, Lisp_PipeErrorDescriptor, "pipe-error-descriptor pipe-stream"},
593 {LispFunction, Lisp_Recomp, "re-comp pattern &key nospec icase nosub newline"},
594 {LispFunction, Lisp_Reexec, "re-exec regex string &key count start end notbol noteol"},
595 {LispFunction, Lisp_Rep, "re-p object"},
596 {LispFunction, Lisp_Setenv, "setenv name value &optional overwrite"},
597 {LispFunction, Lisp_Unsetenv, "unsetenv name"},
598 {LispFunction, Lisp_NstringTrim, "nstring-trim character-bag string"},
599 {LispFunction, Lisp_NstringLeftTrim, "nstring-left-trim character-bag string"},
600 {LispFunction, Lisp_NstringRightTrim, "nstring-right-trim character-bag string"},
601 {LispMacro, Lisp_Until, "until test &rest body", 0, 0, Com_Until},
602 {LispMacro, Lisp_While, "while test &rest body", 0, 0, Com_While},
603 };
604
605 /* byte code function argument list for functions that don't change it's
606 * &REST argument list. */
607 extern LispObj x_cons[8];
608
609 /*
610 * Implementation
611 */
612 static int
LispGetPageSize(void)613 LispGetPageSize(void)
614 {
615 static int pagesize = -1;
616
617 if (pagesize != -1)
618 return pagesize;
619
620 /* Try each supported method in the preferred order */
621
622 #if defined(_SC_PAGESIZE) || defined(HAVE_DECL__SC_PAGESIZE)
623 pagesize = sysconf(_SC_PAGESIZE);
624 #endif
625
626 #ifdef _SC_PAGE_SIZE
627 if (pagesize == -1)
628 pagesize = sysconf(_SC_PAGE_SIZE);
629 #endif
630
631 #ifdef HAVE_GETPAGESIZE
632 if (pagesize == -1)
633 pagesize = getpagesize();
634 #endif
635
636 #ifdef PAGE_SIZE
637 if (pagesize == -1)
638 pagesize = PAGE_SIZE;
639 #endif
640
641 if (pagesize < sizeof(LispObj) * 16)
642 pagesize = sizeof(LispObj) * 16; /* need a reasonable sane size */
643
644 return pagesize;
645 }
646
647 void
LispDestroy(const char * fmt,...)648 LispDestroy(const char *fmt, ...)
649 {
650 static char Error[] = "*** ";
651
652 if (!lisp__data.destroyed) {
653 char string[128];
654 va_list ap;
655
656 va_start(ap, fmt);
657 vsnprintf(string, sizeof(string), fmt, ap);
658 va_end(ap);
659
660 if (!lisp__data.ignore_errors) {
661 if (Stderr->column)
662 LispFputc(Stderr, '\n');
663 LispFputs(Stderr, Error);
664 LispFputs(Stderr, string);
665 LispFputc(Stderr, '\n');
666 LispFflush(Stderr);
667 }
668 else
669 lisp__data.error_condition = STRING(string);
670
671 #ifdef DEBUGGER
672 if (lisp__data.debugging) {
673 LispDebugger(LispDebugCallWatch, NIL, NIL);
674 LispDebugger(LispDebugCallFatal, NIL, NIL);
675 }
676 #endif
677
678 lisp__data.destroyed = 1;
679 LispBlockUnwind(NULL);
680 if (lisp__data.errexit)
681 exit(1);
682 }
683
684 #ifdef DEBUGGER
685 if (lisp__data.debugging) {
686 /* when stack variables could be changed, this must be also changed! */
687 lisp__data.debug_level = -1;
688 lisp__data.debug = LispDebugUnspec;
689 }
690 #endif
691
692 while (lisp__data.mem.level) {
693 --lisp__data.mem.level;
694 if (lisp__data.mem.mem[lisp__data.mem.level])
695 free(lisp__data.mem.mem[lisp__data.mem.level]);
696 }
697 lisp__data.mem.index = 0;
698
699 /* If the package was changed and an error happened */
700 PACKAGE = lisp__data.savepackage;
701 lisp__data.pack = lisp__data.savepack;
702
703 LispTopLevel();
704
705 if (!lisp__data.running) {
706 static const char *Fatal = "*** Fatal: nowhere to longjmp.\n";
707
708 LispFputs(Stderr, Fatal);
709 LispFflush(Stderr);
710 abort();
711 }
712
713 siglongjmp(lisp__data.jmp, 1);
714 }
715
716 void
LispContinuable(const char * fmt,...)717 LispContinuable(const char *fmt, ...)
718 {
719 va_list ap;
720 char string[128];
721 static const char *Error = "*** Error: ";
722
723 if (Stderr->column)
724 LispFputc(Stderr, '\n');
725 LispFputs(Stderr, Error);
726 va_start(ap, fmt);
727 vsnprintf(string, sizeof(string), fmt, ap);
728 va_end(ap);
729 LispFputs(Stderr, string);
730 LispFputc(Stderr, '\n');
731 LispFputs(Stderr, "Type 'continue' if you want to proceed: ");
732 LispFflush(Stderr);
733
734 /* NOTE: does not check if stdin is a tty */
735 if (LispFgets(Stdin, string, sizeof(string)) &&
736 strcmp(string, "continue\n") == 0)
737 return;
738
739 LispDestroy("aborted on continuable error");
740 }
741
742 void
LispMessage(const char * fmt,...)743 LispMessage(const char *fmt, ...)
744 {
745 va_list ap;
746 char string[128];
747
748 if (Stderr->column)
749 LispFputc(Stderr, '\n');
750 va_start(ap, fmt);
751 vsnprintf(string, sizeof(string), fmt, ap);
752 va_end(ap);
753 LispFputs(Stderr, string);
754 LispFputc(Stderr, '\n');
755 LispFflush(Stderr);
756 }
757
758 void
LispWarning(const char * fmt,...)759 LispWarning(const char *fmt, ...)
760 {
761 va_list ap;
762 char string[128];
763 static const char *Warning = "*** Warning: ";
764
765 if (Stderr->column)
766 LispFputc(Stderr, '\n');
767 LispFputs(Stderr, Warning);
768 va_start(ap, fmt);
769 vsnprintf(string, sizeof(string), fmt, ap);
770 va_end(ap);
771 LispFputs(Stderr, string);
772 LispFputc(Stderr, '\n');
773 LispFflush(Stderr);
774 }
775
776 void
LispTopLevel(void)777 LispTopLevel(void)
778 {
779 int count;
780
781 COD = NIL;
782 #ifdef DEBUGGER
783 if (lisp__data.debugging) {
784 DBG = NIL;
785 if (lisp__data.debug == LispDebugFinish)
786 lisp__data.debug = LispDebugUnspec;
787 lisp__data.debug_level = -1;
788 lisp__data.debug_step = 0;
789 }
790 #endif
791 gcpro = 0;
792 lisp__data.block.block_level = 0;
793 if (lisp__data.block.block_size) {
794 while (lisp__data.block.block_size)
795 free(lisp__data.block.block[--lisp__data.block.block_size]);
796 free(lisp__data.block.block);
797 lisp__data.block.block = NULL;
798 }
799
800 lisp__data.destroyed = lisp__data.ignore_errors = 0;
801
802 if (CONSP(lisp__data.input_list)) {
803 LispUngetInfo **info, *unget = lisp__data.unget[0];
804
805 while (CONSP(lisp__data.input_list))
806 lisp__data.input_list = CDR(lisp__data.input_list);
807 SINPUT = lisp__data.input_list;
808 while (lisp__data.nunget > 1)
809 free(lisp__data.unget[--lisp__data.nunget]);
810 if ((info = realloc(lisp__data.unget, sizeof(LispUngetInfo*))) != NULL)
811 lisp__data.unget = info;
812 lisp__data.unget[0] = unget;
813 lisp__data.iunget = 0;
814 lisp__data.eof = 0;
815 }
816
817 for (count = 0; lisp__data.mem.level;) {
818 --lisp__data.mem.level;
819 if (lisp__data.mem.mem[lisp__data.mem.level]) {
820 ++count;
821 #if 0
822 printf("LEAK: %p\n", lisp__data.mem.mem[lisp__data.mem.level]);
823 #endif
824 }
825 }
826 lisp__data.mem.index = 0;
827 if (count)
828 LispWarning("%d raw memory pointer(s) left. Probably a leak.", count);
829
830 lisp__data.stack.base = lisp__data.stack.length =
831 lisp__data.env.lex = lisp__data.env.length = lisp__data.env.head = 0;
832 RETURN_COUNT = 0;
833 lisp__data.protect.length = 0;
834
835 lisp__data.savepackage = PACKAGE;
836 lisp__data.savepack = lisp__data.pack;
837
838 lisp__disable_int = lisp__interrupted = 0;
839 }
840
841 void
LispGC(LispObj * car,LispObj * cdr)842 LispGC(LispObj *car, LispObj *cdr)
843 {
844 Lisp__GC(car, cdr);
845 }
846
847 static void
Lisp__GC(LispObj * car,LispObj * cdr)848 Lisp__GC(LispObj *car, LispObj *cdr)
849 {
850 register LispObj *entry, *last, *freeobj, **pentry, **eentry;
851 register int nfree;
852 unsigned i, j;
853 LispAtom *atom;
854 struct timeval start, end;
855 #ifdef DEBUG
856 long sec, msec;
857 int count = objseg.nfree;
858 #else
859 long msec;
860 #endif
861
862 if (gcpro)
863 return;
864
865 DISABLE_INTERRUPTS();
866
867 nfree = 0;
868 freeobj = NIL;
869
870 ++lisp__data.gc.count;
871
872 #ifdef DEBUG
873 gettimeofday(&start, NULL);
874 #else
875 if (lisp__data.gc.timebits)
876 gettimeofday(&start, NULL);
877 #endif
878
879 /* Need to measure timings again to check if it is not better/faster
880 * to just mark these fields as any other data, as the interface was
881 * changed to properly handle circular lists in the function body itself.
882 */
883 if (lisp__data.gc.immutablebits) {
884 for (j = 0; j < objseg.nsegs; j++) {
885 for (entry = objseg.objects[j], last = entry + segsize;
886 entry < last; entry++)
887 entry->prot = 0;
888 }
889 }
890
891 /* Protect all packages */
892 for (entry = PACK; CONSP(entry); entry = CDR(entry)) {
893 LispObj *package = CAR(entry);
894 LispPackage *pack = package->data.package.package;
895
896 /* Protect cons cell */
897 entry->mark = 1;
898
899 /* Protect the package cell */
900 package->mark = 1;
901
902 /* Protect package name */
903 package->data.package.name->mark = 1;
904
905 /* Protect package nicknames */
906 LispMark(package->data.package.nicknames);
907
908 /* Protect global symbols */
909 for (pentry = pack->glb.pairs, eentry = pentry + pack->glb.length;
910 pentry < eentry; pentry++)
911 LispMark((*pentry)->data.atom->property->value);
912
913 /* Traverse atom list, protecting properties, and function/structure
914 * definitions if lisp__data.gc.immutablebits set */
915 for (atom = (LispAtom *)hash_iter_first(pack->atoms);
916 atom;
917 atom = (LispAtom *)hash_iter_next(pack->atoms)) {
918 if (atom->property != NOPROPERTY) {
919 if (atom->a_property)
920 LispMark(atom->property->properties);
921 if (lisp__data.gc.immutablebits) {
922 if (atom->a_function || atom->a_compiled)
923 LispProt(atom->property->fun.function);
924 if (atom->a_defsetf)
925 LispProt(atom->property->setf);
926 if (atom->a_defstruct)
927 LispProt(atom->property->structure.definition);
928 }
929 }
930 }
931 }
932
933 /* protect environment */
934 for (pentry = lisp__data.env.values,
935 eentry = pentry + lisp__data.env.length;
936 pentry < eentry; pentry++)
937 LispMark(*pentry);
938
939 /* protect multiple return values */
940 for (pentry = lisp__data.returns.values,
941 eentry = pentry + lisp__data.returns.count;
942 pentry < eentry; pentry++)
943 LispMark(*pentry);
944
945 /* protect stack of arguments to builtin functions */
946 for (pentry = lisp__data.stack.values,
947 eentry = pentry + lisp__data.stack.length;
948 pentry < eentry; pentry++)
949 LispMark(*pentry);
950
951 /* protect temporary data used by builtin functions */
952 for (pentry = lisp__data.protect.objects,
953 eentry = pentry + lisp__data.protect.length;
954 pentry < eentry; pentry++)
955 LispMark(*pentry);
956
957 for (i = 0; i < sizeof(x_cons) / sizeof(x_cons[0]); i++)
958 x_cons[i].mark = 0;
959
960 LispMark(COD);
961 #ifdef DEBUGGER
962 LispMark(DBG);
963 LispMark(BRK);
964 #endif
965 LispMark(PRO);
966 LispMark(lisp__data.input_list);
967 LispMark(lisp__data.output_list);
968 LispMark(car);
969 LispMark(cdr);
970
971 for (j = 0; j < objseg.nsegs; j++) {
972 for (entry = objseg.objects[j], last = entry + segsize;
973 entry < last; entry++) {
974 if (entry->prot)
975 continue;
976 else if (entry->mark)
977 entry->mark = 0;
978 else {
979 switch (XOBJECT_TYPE(entry)) {
980 case LispString_t:
981 free(THESTR(entry));
982 entry->type = LispCons_t;
983 break;
984 case LispStream_t:
985 switch (entry->data.stream.type) {
986 case LispStreamString:
987 free(SSTREAMP(entry)->string);
988 free(SSTREAMP(entry));
989 break;
990 case LispStreamFile:
991 if (FSTREAMP(entry))
992 LispFclose(FSTREAMP(entry));
993 break;
994 case LispStreamPipe:
995 /* XXX may need special handling if child hangs */
996 if (PSTREAMP(entry)) {
997 if (IPSTREAMP(entry))
998 LispFclose(IPSTREAMP(entry));
999 if (OPSTREAMP(entry))
1000 LispFclose(OPSTREAMP(entry));
1001 /* don't bother with error stream, will also
1002 * freed in this GC call, maybe just out
1003 * of order */
1004 if (PIDPSTREAMP(entry) > 0) {
1005 kill(PIDPSTREAMP(entry), SIGTERM);
1006 waitpid(PIDPSTREAMP(entry), NULL, 0);
1007 }
1008 free(PSTREAMP(entry));
1009 }
1010 break;
1011 default:
1012 break;
1013 }
1014 entry->type = LispCons_t;
1015 break;
1016 case LispBignum_t:
1017 mpi_clear(entry->data.mp.integer);
1018 free(entry->data.mp.integer);
1019 entry->type = LispCons_t;
1020 break;
1021 case LispBigratio_t:
1022 mpr_clear(entry->data.mp.ratio);
1023 free(entry->data.mp.ratio);
1024 entry->type = LispCons_t;
1025 break;
1026 case LispLambda_t:
1027 if (!SYMBOLP(entry->data.lambda.name))
1028 LispFreeArgList((LispArgList*)
1029 entry->data.lambda.name->data.opaque.data);
1030 entry->type = LispCons_t;
1031 break;
1032 case LispRegex_t:
1033 refree(entry->data.regex.regex);
1034 free(entry->data.regex.regex);
1035 entry->type = LispCons_t;
1036 break;
1037 case LispBytecode_t:
1038 free(entry->data.bytecode.bytecode->code);
1039 free(entry->data.bytecode.bytecode);
1040 entry->type = LispCons_t;
1041 break;
1042 case LispHashTable_t:
1043 LispFreeHashTable(entry->data.hash.table);
1044 entry->type = LispCons_t;
1045 break;
1046 case LispCons_t:
1047 break;
1048 default:
1049 entry->type = LispCons_t;
1050 break;
1051 }
1052 CDR(entry) = freeobj;
1053 freeobj = entry;
1054 ++nfree;
1055 }
1056 }
1057 }
1058
1059 objseg.nfree = nfree;
1060 objseg.freeobj = freeobj;
1061
1062 lisp__data.gc.immutablebits = 0;
1063
1064 #ifdef DEBUG
1065 gettimeofday(&end, NULL);
1066 sec = end.tv_sec - start.tv_sec;
1067 msec = end.tv_usec - start.tv_usec;
1068 if (msec < 0) {
1069 --sec;
1070 msec += 1000000;
1071 }
1072 LispMessage("gc: "
1073 "%ld sec, %ld msec, "
1074 "%d recovered, %d free, %d protected, %d total",
1075 sec, msec,
1076 objseg.nfree - count, objseg.nfree,
1077 objseg.nobjs - objseg.nfree, objseg.nobjs);
1078 #else
1079 if (lisp__data.gc.timebits) {
1080 gettimeofday(&end, NULL);
1081 if ((msec = end.tv_usec - start.tv_usec) < 0)
1082 msec += 1000000;
1083 lisp__data.gc.gctime += msec;
1084 }
1085 #endif
1086
1087 ENABLE_INTERRUPTS();
1088 }
1089
1090 static INLINE void
LispCheckMemLevel(void)1091 LispCheckMemLevel(void)
1092 {
1093 int i;
1094
1095 /* Check for a free slot before the end. */
1096 for (i = lisp__data.mem.index; i < lisp__data.mem.level; i++)
1097 if (lisp__data.mem.mem[i] == NULL) {
1098 lisp__data.mem.index = i;
1099 return;
1100 }
1101
1102 /* Check for a free slot in the beginning */
1103 for (i = 0; i < lisp__data.mem.index; i++)
1104 if (lisp__data.mem.mem[i] == NULL) {
1105 lisp__data.mem.index = i;
1106 return;
1107 }
1108
1109 lisp__data.mem.index = lisp__data.mem.level;
1110 ++lisp__data.mem.level;
1111 if (lisp__data.mem.index < lisp__data.mem.space)
1112 /* There is free space to store pointer. */
1113 return;
1114 else {
1115 void **ptr = (void**)realloc(lisp__data.mem.mem,
1116 (lisp__data.mem.space + 16) *
1117 sizeof(void*));
1118
1119 if (ptr == NULL)
1120 LispDestroy("out of memory");
1121 lisp__data.mem.mem = ptr;
1122 lisp__data.mem.space += 16;
1123 }
1124 }
1125
1126 void
LispMused(void * pointer)1127 LispMused(void *pointer)
1128 {
1129 int i;
1130
1131 DISABLE_INTERRUPTS();
1132 for (i = lisp__data.mem.index; i >= 0; i--)
1133 if (lisp__data.mem.mem[i] == pointer) {
1134 lisp__data.mem.mem[i] = NULL;
1135 lisp__data.mem.index = i;
1136 goto mused_done;
1137 }
1138
1139 for (i = lisp__data.mem.level - 1; i > lisp__data.mem.index; i--)
1140 if (lisp__data.mem.mem[i] == pointer) {
1141 lisp__data.mem.mem[i] = NULL;
1142 lisp__data.mem.index = i;
1143 break;
1144 }
1145
1146 mused_done:
1147 ENABLE_INTERRUPTS();
1148 }
1149
1150 void *
LispMalloc(size_t size)1151 LispMalloc(size_t size)
1152 {
1153 void *pointer;
1154
1155 DISABLE_INTERRUPTS();
1156 LispCheckMemLevel();
1157 if ((pointer = malloc(size)) == NULL)
1158 LispDestroy("out of memory, couldn't allocate %lu bytes",
1159 (unsigned long)size);
1160
1161 lisp__data.mem.mem[lisp__data.mem.index] = pointer;
1162 ENABLE_INTERRUPTS();
1163
1164 return (pointer);
1165 }
1166
1167 void *
LispCalloc(size_t nmemb,size_t size)1168 LispCalloc(size_t nmemb, size_t size)
1169 {
1170 void *pointer;
1171
1172 DISABLE_INTERRUPTS();
1173 LispCheckMemLevel();
1174 if ((pointer = calloc(nmemb, size)) == NULL)
1175 LispDestroy("out of memory, couldn't allocate %lu bytes",
1176 (unsigned long)size);
1177
1178 lisp__data.mem.mem[lisp__data.mem.index] = pointer;
1179 ENABLE_INTERRUPTS();
1180
1181 return (pointer);
1182 }
1183
1184 void *
LispRealloc(void * pointer,size_t size)1185 LispRealloc(void *pointer, size_t size)
1186 {
1187 void *ptr;
1188 int i;
1189
1190 DISABLE_INTERRUPTS();
1191 if (pointer != NULL) {
1192 for (i = lisp__data.mem.index; i >= 0; i--)
1193 if (lisp__data.mem.mem[i] == pointer)
1194 goto index_found;
1195
1196 for (i = lisp__data.mem.index + 1; i < lisp__data.mem.level; i++)
1197 if (lisp__data.mem.mem[i] == pointer)
1198 goto index_found;
1199
1200 }
1201 LispCheckMemLevel();
1202 i = lisp__data.mem.index;
1203
1204 index_found:
1205 if ((ptr = realloc(pointer, size)) == NULL)
1206 LispDestroy("out of memory, couldn't realloc");
1207
1208 lisp__data.mem.mem[i] = ptr;
1209 ENABLE_INTERRUPTS();
1210
1211 return (ptr);
1212 }
1213
1214 char *
LispStrdup(const char * str)1215 LispStrdup(const char *str)
1216 {
1217 char *ptr = LispMalloc(strlen(str) + 1);
1218
1219 strcpy(ptr, str);
1220
1221 return (ptr);
1222 }
1223
1224 void
LispFree(void * pointer)1225 LispFree(void *pointer)
1226 {
1227 int i;
1228
1229 DISABLE_INTERRUPTS();
1230 for (i = lisp__data.mem.index; i >= 0; i--)
1231 if (lisp__data.mem.mem[i] == pointer) {
1232 lisp__data.mem.mem[i] = NULL;
1233 lisp__data.mem.index = i;
1234 goto free_done;
1235 }
1236
1237 for (i = lisp__data.mem.level - 1; i > lisp__data.mem.index; i--)
1238 if (lisp__data.mem.mem[i] == pointer) {
1239 lisp__data.mem.mem[i] = NULL;
1240 lisp__data.mem.index = i;
1241 break;
1242 }
1243
1244 free_done:
1245 free(pointer);
1246 ENABLE_INTERRUPTS();
1247 }
1248
1249 LispObj *
LispSetVariable(LispObj * var,LispObj * val,const char * fname,int eval)1250 LispSetVariable(LispObj *var, LispObj *val, const char *fname, int eval)
1251 {
1252 if (!SYMBOLP(var))
1253 LispDestroy("%s: %s is not a symbol", fname, STROBJ(var));
1254 if (eval)
1255 val = EVAL(val);
1256
1257 return (LispSetVar(var, val));
1258 }
1259
1260 int
LispRegisterOpaqueType(const char * desc)1261 LispRegisterOpaqueType(const char *desc)
1262 {
1263 int length;
1264 LispOpaque *opaque;
1265
1266 length = strlen(desc);
1267 opaque = (LispOpaque *)hash_check(lisp__data.opqs, desc, length);
1268
1269 if (opaque == NULL) {
1270 opaque = (LispOpaque*)LispMalloc(sizeof(LispOpaque));
1271 opaque->desc = (hash_key*)LispCalloc(1, sizeof(hash_key));
1272 opaque->desc->value = LispStrdup(desc);
1273 opaque->desc->length = length;
1274 hash_put(lisp__data.opqs, (hash_entry *)opaque);
1275 LispMused(opaque->desc->value);
1276 LispMused(opaque->desc);
1277 LispMused(opaque);
1278 opaque->type = ++lisp__data.opaque;
1279 }
1280
1281 return (opaque->type);
1282 }
1283
1284 char *
LispIntToOpaqueType(int type)1285 LispIntToOpaqueType(int type)
1286 {
1287 LispOpaque *opaque;
1288
1289 if (type) {
1290 for (opaque = (LispOpaque *)hash_iter_first(lisp__data.opqs);
1291 opaque;
1292 opaque = (LispOpaque *)hash_iter_next(lisp__data.opqs)) {
1293 if (opaque->type == type)
1294 return (opaque->desc->value);
1295 }
1296 LispDestroy("Opaque type %d not registered", type);
1297 }
1298
1299 return (Snil->value);
1300 }
1301
1302 hash_key *
LispGetAtomKey(const char * string,int perm)1303 LispGetAtomKey(const char *string, int perm)
1304 {
1305 int length;
1306 hash_entry *entry;
1307
1308 length = strlen(string);
1309 entry = hash_check(lisp__data.strings, string, length);
1310 if (entry == NULL) {
1311 entry = LispCalloc(1, sizeof(hash_entry));
1312 entry->key = LispCalloc(1, sizeof(hash_key));
1313 if (perm)
1314 entry->key->value = (char *) string;
1315 else
1316 entry->key->value = LispStrdup(string);
1317 entry->key->length = length;
1318
1319 hash_put(lisp__data.strings, entry);
1320 if (!perm)
1321 LispMused(entry->key->value);
1322 LispMused(entry->key);
1323 LispMused(entry);
1324 }
1325
1326 return (entry->key);
1327 }
1328
1329 LispAtom *
LispDoGetAtom(const char * str,int perm)1330 LispDoGetAtom(const char *str, int perm)
1331 {
1332 int length;
1333 LispAtom *atom;
1334
1335 length = strlen(str);
1336 atom = (LispAtom *)hash_check(lisp__data.pack->atoms, str, length);
1337
1338 if (atom == NULL) {
1339 atom = (LispAtom*)LispCalloc(1, sizeof(LispAtom));
1340 atom->key = LispGetAtomKey(str, perm);
1341 hash_put(lisp__data.pack->atoms, (hash_entry *)atom);
1342 atom->property = NOPROPERTY;
1343 LispMused(atom);
1344 }
1345
1346 return (atom);
1347 }
1348
1349 static void
LispAllocAtomProperty(LispAtom * atom)1350 LispAllocAtomProperty(LispAtom *atom)
1351 {
1352 LispProperty *property;
1353
1354 if (atom->property != NOPROPERTY)
1355 LispDestroy("internal error at ALLOC-ATOM-PROPERTY");
1356
1357 property = LispCalloc(1, sizeof(LispProperty));
1358 LispMused(property);
1359 atom->property = property;
1360 property->package = lisp__data.pack;
1361 if (atom->package == NULL)
1362 atom->package = PACKAGE;
1363
1364 LispIncrementAtomReference(atom);
1365 }
1366
1367 static void
LispIncrementAtomReference(LispAtom * atom)1368 LispIncrementAtomReference(LispAtom *atom)
1369 {
1370 if (atom->property != NOPROPERTY)
1371 /* if atom->property is NOPROPERTY, this is an unbound symbol */
1372 ++atom->property->refcount;
1373 }
1374
1375 /* Assumes atom property is not NOPROPERTY */
1376 static void
LispDecrementAtomReference(LispAtom * atom)1377 LispDecrementAtomReference(LispAtom *atom)
1378 {
1379 if (atom->property == NOPROPERTY)
1380 /* if atom->property is NOPROPERTY, this is an unbound symbol */
1381 return;
1382
1383 if (atom->property->refcount <= 0)
1384 LispDestroy("internal error at DECREMENT-ATOM-REFERENCE");
1385
1386 --atom->property->refcount;
1387
1388 if (atom->property->refcount == 0) {
1389 LispRemAtomAllProperties(atom);
1390 free(atom->property);
1391 atom->property = NOPROPERTY;
1392 }
1393 }
1394
1395 static void
LispRemAtomAllProperties(LispAtom * atom)1396 LispRemAtomAllProperties(LispAtom *atom)
1397 {
1398 if (atom->property != NOPROPERTY) {
1399 if (atom->a_object)
1400 LispRemAtomObjectProperty(atom);
1401 if (atom->a_function) {
1402 lisp__data.gc.immutablebits = 1;
1403 LispRemAtomFunctionProperty(atom);
1404 }
1405 else if (atom->a_compiled) {
1406 lisp__data.gc.immutablebits = 1;
1407 LispRemAtomCompiledProperty(atom);
1408 }
1409 else if (atom->a_builtin) {
1410 lisp__data.gc.immutablebits = 1;
1411 LispRemAtomBuiltinProperty(atom);
1412 }
1413 if (atom->a_defsetf) {
1414 lisp__data.gc.immutablebits = 1;
1415 LispRemAtomSetfProperty(atom);
1416 }
1417 if (atom->a_defstruct) {
1418 lisp__data.gc.immutablebits = 1;
1419 LispRemAtomStructProperty(atom);
1420 }
1421 }
1422 }
1423
1424 void
LispSetAtomObjectProperty(LispAtom * atom,LispObj * object)1425 LispSetAtomObjectProperty(LispAtom *atom, LispObj *object)
1426 {
1427 if (atom->property == NOPROPERTY)
1428 LispAllocAtomProperty(atom);
1429 else if (atom->watch) {
1430 if (atom->object == lisp__data.package) {
1431 if (!PACKAGEP(object))
1432 LispDestroy("Symbol %s must be a package, not %s",
1433 ATOMID(lisp__data.package)->value, STROBJ(object));
1434 lisp__data.pack = object->data.package.package;
1435 }
1436 }
1437
1438 atom->a_object = 1;
1439 SETVALUE(atom, object);
1440 }
1441
1442 static void
LispRemAtomObjectProperty(LispAtom * atom)1443 LispRemAtomObjectProperty(LispAtom *atom)
1444 {
1445 if (atom->a_object) {
1446 atom->a_object = 0;
1447 atom->property->value = NULL;
1448 }
1449 }
1450
1451 void
LispSetAtomCompiledProperty(LispAtom * atom,LispObj * bytecode)1452 LispSetAtomCompiledProperty(LispAtom *atom, LispObj *bytecode)
1453 {
1454 if (atom->property == NOPROPERTY)
1455 LispAllocAtomProperty(atom);
1456
1457 lisp__data.gc.immutablebits = 1;
1458 if (atom->a_builtin) {
1459 atom->a_builtin = 0;
1460 LispFreeArgList(atom->property->alist);
1461 }
1462 else
1463 atom->a_function = 0;
1464 atom->a_compiled = 1;
1465 atom->property->fun.function = bytecode;
1466 }
1467
1468 void
LispRemAtomCompiledProperty(LispAtom * atom)1469 LispRemAtomCompiledProperty(LispAtom *atom)
1470 {
1471 if (atom->a_compiled) {
1472 lisp__data.gc.immutablebits = 1;
1473 atom->property->fun.function = NULL;
1474 atom->a_compiled = 0;
1475 LispFreeArgList(atom->property->alist);
1476 atom->property->alist = NULL;
1477 }
1478 }
1479
1480 void
LispSetAtomFunctionProperty(LispAtom * atom,LispObj * function,LispArgList * alist)1481 LispSetAtomFunctionProperty(LispAtom *atom, LispObj *function,
1482 LispArgList *alist)
1483 {
1484 if (atom->property == NOPROPERTY)
1485 LispAllocAtomProperty(atom);
1486
1487 lisp__data.gc.immutablebits = 1;
1488 if (atom->a_function == 0 && atom->a_builtin == 0 && atom->a_compiled == 0)
1489 atom->a_function = 1;
1490 else {
1491 if (atom->a_builtin) {
1492 atom->a_builtin = 0;
1493 LispFreeArgList(atom->property->alist);
1494 }
1495 else
1496 atom->a_compiled = 0;
1497 atom->a_function = 1;
1498 }
1499
1500 atom->property->fun.function = function;
1501 atom->property->alist = alist;
1502 }
1503
1504 void
LispRemAtomFunctionProperty(LispAtom * atom)1505 LispRemAtomFunctionProperty(LispAtom *atom)
1506 {
1507 if (atom->a_function) {
1508 lisp__data.gc.immutablebits = 1;
1509 atom->property->fun.function = NULL;
1510 atom->a_function = 0;
1511 LispFreeArgList(atom->property->alist);
1512 atom->property->alist = NULL;
1513 }
1514 }
1515
1516 void
LispSetAtomBuiltinProperty(LispAtom * atom,LispBuiltin * builtin,LispArgList * alist)1517 LispSetAtomBuiltinProperty(LispAtom *atom, LispBuiltin *builtin,
1518 LispArgList *alist)
1519 {
1520 if (atom->property == NOPROPERTY)
1521 LispAllocAtomProperty(atom);
1522
1523 lisp__data.gc.immutablebits = 1;
1524 if (atom->a_builtin == 0 && atom->a_function == 0)
1525 atom->a_builtin = 1;
1526 else {
1527 if (atom->a_function) {
1528 atom->a_function = 0;
1529 LispFreeArgList(atom->property->alist);
1530 }
1531 }
1532
1533 atom->property->fun.builtin = builtin;
1534 atom->property->alist = alist;
1535 }
1536
1537 void
LispRemAtomBuiltinProperty(LispAtom * atom)1538 LispRemAtomBuiltinProperty(LispAtom *atom)
1539 {
1540 if (atom->a_builtin) {
1541 lisp__data.gc.immutablebits = 1;
1542 atom->property->fun.function = NULL;
1543 atom->a_builtin = 0;
1544 LispFreeArgList(atom->property->alist);
1545 atom->property->alist = NULL;
1546 }
1547 }
1548
1549 void
LispSetAtomSetfProperty(LispAtom * atom,LispObj * setf,LispArgList * alist)1550 LispSetAtomSetfProperty(LispAtom *atom, LispObj *setf, LispArgList *alist)
1551 {
1552 if (atom->property == NOPROPERTY)
1553 LispAllocAtomProperty(atom);
1554
1555 lisp__data.gc.immutablebits = 1;
1556 if (atom->a_defsetf)
1557 LispFreeArgList(atom->property->salist);
1558
1559 atom->a_defsetf = 1;
1560 atom->property->setf = setf;
1561 atom->property->salist = alist;
1562 }
1563
1564 void
LispRemAtomSetfProperty(LispAtom * atom)1565 LispRemAtomSetfProperty(LispAtom *atom)
1566 {
1567 if (atom->a_defsetf) {
1568 lisp__data.gc.immutablebits = 1;
1569 atom->property->setf = NULL;
1570 atom->a_defsetf = 0;
1571 LispFreeArgList(atom->property->salist);
1572 atom->property->salist = NULL;
1573 }
1574 }
1575
1576 void
LispSetAtomStructProperty(LispAtom * atom,LispObj * def,int fun)1577 LispSetAtomStructProperty(LispAtom *atom, LispObj *def, int fun)
1578 {
1579 if (fun > 0xff)
1580 /* Not suported by the bytecode compiler... */
1581 LispDestroy("SET-ATOM-STRUCT-PROPERTY: "
1582 "more than 256 fields not supported");
1583
1584 if (atom->property == NOPROPERTY)
1585 LispAllocAtomProperty(atom);
1586
1587 lisp__data.gc.immutablebits = 1;
1588 atom->a_defstruct = 1;
1589 atom->property->structure.definition = def;
1590 atom->property->structure.function = fun;
1591 }
1592
1593 void
LispRemAtomStructProperty(LispAtom * atom)1594 LispRemAtomStructProperty(LispAtom *atom)
1595 {
1596 if (atom->a_defstruct) {
1597 lisp__data.gc.immutablebits = 1;
1598 atom->property->structure.definition = NULL;
1599 atom->a_defstruct = 0;
1600 }
1601 }
1602
1603 LispAtom *
LispGetAtom(const char * str)1604 LispGetAtom(const char *str)
1605 {
1606 return (LispDoGetAtom(str, 0));
1607 }
1608
1609 LispAtom *
LispGetPermAtom(const char * str)1610 LispGetPermAtom(const char *str)
1611 {
1612 return (LispDoGetAtom(str, 1));
1613 }
1614
1615 #define GET_PROPERTY 0
1616 #define ADD_PROPERTY 1
1617 #define REM_PROPERTY 2
1618 static LispObj *
LispAtomPropertyFunction(LispAtom * atom,LispObj * key,int function)1619 LispAtomPropertyFunction(LispAtom *atom, LispObj *key, int function)
1620 {
1621 LispObj *list = NIL, *result = NIL;
1622
1623 if (function == ADD_PROPERTY) {
1624 if (atom->property == NOPROPERTY)
1625 LispAllocAtomProperty(atom);
1626 if (atom->property->properties == NULL) {
1627 atom->a_property = 1;
1628 atom->property->properties = NIL;
1629 }
1630 }
1631
1632 if (atom->a_property) {
1633 LispObj *base;
1634
1635 for (base = list = atom->property->properties;
1636 CONSP(list);
1637 list = CDR(list)) {
1638 if (key == CAR(list)) {
1639 result = CDR(list);
1640 break;
1641 }
1642 base = list;
1643 list = CDR(list);
1644 if (!CONSP(list))
1645 LispDestroy("%s: %s has an odd property list length",
1646 STROBJ(atom->object),
1647 function == REM_PROPERTY ? "REMPROP" : "GET");
1648 }
1649 if (CONSP(list) && function == REM_PROPERTY) {
1650 if (!CONSP(CDR(list)))
1651 LispDestroy("REMPROP: %s has an odd property list length",
1652 STROBJ(atom->object));
1653 if (base == list)
1654 atom->property->properties = CDDR(list);
1655 else
1656 RPLACD(CDR(base), CDDR(list));
1657 }
1658 }
1659
1660 if (!CONSP(list)) {
1661 if (function == ADD_PROPERTY) {
1662 atom->property->properties =
1663 CONS(key, CONS(NIL, atom->property->properties));
1664 result = CDR(atom->property->properties);
1665 }
1666 }
1667 else if (function == REM_PROPERTY)
1668 result = T;
1669
1670 return (result);
1671 }
1672
1673 LispObj *
LispGetAtomProperty(LispAtom * atom,LispObj * key)1674 LispGetAtomProperty(LispAtom *atom, LispObj *key)
1675 {
1676 return (LispAtomPropertyFunction(atom, key, GET_PROPERTY));
1677 }
1678
1679 LispObj *
LispPutAtomProperty(LispAtom * atom,LispObj * key,LispObj * value)1680 LispPutAtomProperty(LispAtom *atom, LispObj *key, LispObj *value)
1681 {
1682 LispObj *result = LispAtomPropertyFunction(atom, key, ADD_PROPERTY);
1683
1684 RPLACA(result, value);
1685
1686 return (result);
1687 }
1688
1689 LispObj *
LispRemAtomProperty(LispAtom * atom,LispObj * key)1690 LispRemAtomProperty(LispAtom *atom, LispObj *key)
1691 {
1692 return (LispAtomPropertyFunction(atom, key, REM_PROPERTY));
1693 }
1694
1695 LispObj *
LispReplaceAtomPropertyList(LispAtom * atom,LispObj * list)1696 LispReplaceAtomPropertyList(LispAtom *atom, LispObj *list)
1697 {
1698 if (atom->property == NOPROPERTY)
1699 LispAllocAtomProperty(atom);
1700 if (atom->property->properties == NULL)
1701 atom->a_property = 1;
1702 atom->property->properties = list;
1703
1704 return (list);
1705 }
1706 #undef GET_PROPERTY
1707 #undef ADD_PROPERTY
1708 #undef REM_PROPERTY
1709
1710
1711 /* Used to make sure that when defining a function like:
1712 * (defun my-function (... &key key1 key2 key3 ...)
1713 * key1, key2, and key3 will be in the keyword package
1714 */
1715 static LispObj *
LispCheckKeyword(LispObj * keyword)1716 LispCheckKeyword(LispObj *keyword)
1717 {
1718 if (KEYWORDP(keyword))
1719 return (keyword);
1720
1721 return (KEYWORD(ATOMID(keyword)->value));
1722 }
1723
1724 void
LispUseArgList(LispArgList * alist)1725 LispUseArgList(LispArgList *alist)
1726 {
1727 if (alist->normals.num_symbols)
1728 LispMused(alist->normals.symbols);
1729 if (alist->optionals.num_symbols) {
1730 LispMused(alist->optionals.symbols);
1731 LispMused(alist->optionals.defaults);
1732 LispMused(alist->optionals.sforms);
1733 }
1734 if (alist->keys.num_symbols) {
1735 LispMused(alist->keys.symbols);
1736 LispMused(alist->keys.defaults);
1737 LispMused(alist->keys.sforms);
1738 LispMused(alist->keys.keys);
1739 }
1740 if (alist->auxs.num_symbols) {
1741 LispMused(alist->auxs.symbols);
1742 LispMused(alist->auxs.initials);
1743 }
1744 LispMused(alist);
1745 }
1746
1747 void
LispFreeArgList(LispArgList * alist)1748 LispFreeArgList(LispArgList *alist)
1749 {
1750 if (alist->normals.num_symbols)
1751 LispFree(alist->normals.symbols);
1752 if (alist->optionals.num_symbols) {
1753 LispFree(alist->optionals.symbols);
1754 LispFree(alist->optionals.defaults);
1755 LispFree(alist->optionals.sforms);
1756 }
1757 if (alist->keys.num_symbols) {
1758 LispFree(alist->keys.symbols);
1759 LispFree(alist->keys.defaults);
1760 LispFree(alist->keys.sforms);
1761 LispFree(alist->keys.keys);
1762 }
1763 if (alist->auxs.num_symbols) {
1764 LispFree(alist->auxs.symbols);
1765 LispFree(alist->auxs.initials);
1766 }
1767 LispFree(alist);
1768 }
1769
1770 static LispObj *
LispCheckNeedProtect(LispObj * object)1771 LispCheckNeedProtect(LispObj *object)
1772 {
1773 if (object) {
1774 switch (OBJECT_TYPE(object)) {
1775 case LispNil_t:
1776 case LispAtom_t:
1777 case LispFunction_t:
1778 case LispFixnum_t:
1779 case LispSChar_t:
1780 return (NULL);
1781 default:
1782 return (object);
1783 }
1784 }
1785 return (NULL);
1786 }
1787
1788 LispObj *
LispListProtectedArguments(LispArgList * alist)1789 LispListProtectedArguments(LispArgList *alist)
1790 {
1791 int i;
1792 GC_ENTER();
1793 LispObj *arguments, *cons, *obj, *prev;
1794
1795 arguments = cons = prev = NIL;
1796 for (i = 0; i < alist->optionals.num_symbols; i++) {
1797 if ((obj = LispCheckNeedProtect(alist->optionals.defaults[i])) != NULL) {
1798 if (arguments == NIL) {
1799 arguments = cons = prev = CONS(obj, NIL);
1800 GC_PROTECT(arguments);
1801 }
1802 else {
1803 RPLACD(cons, CONS(obj, NIL));
1804 prev = cons;
1805 cons = CDR(cons);
1806 }
1807 }
1808 }
1809 for (i = 0; i < alist->keys.num_symbols; i++) {
1810 if ((obj = LispCheckNeedProtect(alist->keys.defaults[i])) != NULL) {
1811 if (arguments == NIL) {
1812 arguments = cons = prev = CONS(obj, NIL);
1813 GC_PROTECT(arguments);
1814 }
1815 else {
1816 RPLACD(cons, CONS(obj, NIL));
1817 prev = cons;
1818 cons = CDR(cons);
1819 }
1820 }
1821 }
1822 for (i = 0; i < alist->auxs.num_symbols; i++) {
1823 if ((obj = LispCheckNeedProtect(alist->auxs.initials[i])) != NULL) {
1824 if (arguments == NIL) {
1825 arguments = cons = prev = CONS(obj, NIL);
1826 GC_PROTECT(arguments);
1827 }
1828 else {
1829 RPLACD(cons, CONS(obj, NIL));
1830 prev = cons;
1831 cons = CDR(cons);
1832 }
1833 }
1834 }
1835 GC_LEAVE();
1836
1837 /* Don't add a NIL cell at the end, to save some space */
1838 if (arguments != NIL) {
1839 if (arguments == cons)
1840 arguments = CAR(cons);
1841 else
1842 CDR(prev) = CAR(cons);
1843 }
1844
1845 return (arguments);
1846 }
1847
1848 LispArgList *
LispCheckArguments(LispFunType type,LispObj * list,const char * name,int builtin)1849 LispCheckArguments(LispFunType type, LispObj *list, const char *name, int builtin)
1850 {
1851 static const char *types[4] = {"LAMBDA-LIST", "FUNCTION", "MACRO", "SETF-METHOD"};
1852 static const char *fnames[4] = {"LAMBDA", "DEFUN", "DEFMACRO", "DEFSETF"};
1853 #define IKEY 0
1854 #define IOPTIONAL 1
1855 #define IREST 2
1856 #define IAUX 3
1857 static const char *keys[4] = {"&KEY", "&OPTIONAL", "&REST", "&AUX"};
1858 int rest, optional, key, aux, count;
1859 LispArgList *alist;
1860 LispObj *spec, *sform, *defval, *default_value;
1861 char description[8], *desc;
1862
1863 /* If LispRealloc fails, the previous memory will be released
1864 * in LispTopLevel, unless LispMused was called on the pointer */
1865 #define REALLOC_OBJECTS(pointer, count) \
1866 pointer = LispRealloc(pointer, (count) * sizeof(LispObj*))
1867
1868 alist = LispCalloc(1, sizeof(LispArgList));
1869 if (!CONSP(list)) {
1870 if (list != NIL)
1871 LispDestroy("%s %s: %s cannot be a %s argument list",
1872 fnames[type], name, STROBJ(list), types[type]);
1873 alist->description = GETATOMID("")->value;
1874
1875 return (alist);
1876 }
1877
1878 default_value = builtin ? UNSPEC : NIL;
1879
1880 description[0] = '\0';
1881 desc = description;
1882 rest = optional = key = aux = 0;
1883 for (; CONSP(list); list = CDR(list)) {
1884 spec = CAR(list);
1885
1886 if (CONSP(spec)) {
1887 if (builtin)
1888 LispDestroy("builtin function argument cannot have default value");
1889 if (aux) {
1890 if (!SYMBOLP(CAR(spec)) ||
1891 (CDR(spec) != NIL && CDDR(spec) != NIL))
1892 LispDestroy("%s %s: bad &AUX argument %s",
1893 fnames[type], name, STROBJ(spec));
1894 defval = CDR(spec) != NIL ? CADR(spec) : NIL;
1895 count = alist->auxs.num_symbols;
1896 REALLOC_OBJECTS(alist->auxs.symbols, count + 1);
1897 REALLOC_OBJECTS(alist->auxs.initials, count + 1);
1898 alist->auxs.symbols[count] = CAR(spec);
1899 alist->auxs.initials[count] = defval;
1900 ++alist->auxs.num_symbols;
1901 if (count == 0)
1902 *desc++ = 'a';
1903 ++alist->num_arguments;
1904 }
1905 else if (rest)
1906 LispDestroy("%s %s: syntax error parsing %s",
1907 fnames[type], name, keys[IREST]);
1908 else if (key) {
1909 LispObj *akey = CAR(spec);
1910
1911 defval = default_value;
1912 sform = NULL;
1913 if (CONSP(akey)) {
1914 /* check for special case, as in:
1915 * (defun a (&key ((key name) 'default-value)) name)
1916 * (a 'key 'test) => TEST
1917 * (a) => DEFAULT-VALUE
1918 */
1919 if (!SYMBOLP(CAR(akey)) || !CONSP(CDR(akey)) ||
1920 !SYMBOLP(CADR(akey)) || CDDR(akey) != NIL ||
1921 (CDR(spec) != NIL && CDDR(spec) != NIL))
1922 LispDestroy("%s %s: bad special &KEY %s",
1923 fnames[type], name, STROBJ(spec));
1924 if (CDR(spec) != NIL)
1925 defval = CADR(spec);
1926 spec = CADR(akey);
1927 akey = CAR(akey);
1928 }
1929 else {
1930 akey = NULL;
1931
1932 if (!SYMBOLP(CAR(spec)))
1933 LispDestroy("%s %s: %s cannot be a %s argument name",
1934 fnames[type], name,
1935 STROBJ(CAR(spec)), types[type]);
1936 /* check if default value provided, and optionally a `svar' */
1937 else if (CDR(spec) != NIL && (!CONSP(CDR(spec)) ||
1938 (CDDR(spec) != NIL &&
1939 (!SYMBOLP(CAR(CDDR(spec))) ||
1940 CDR(CDDR(spec)) != NIL))))
1941 LispDestroy("%s %s: bad argument specification %s",
1942 fnames[type], name, STROBJ(spec));
1943 if (CONSP(CDR(spec))) {
1944 defval = CADR(spec);
1945 if (CONSP(CDDR(spec)))
1946 sform = CAR(CDDR(spec));
1947 }
1948 /* Add to keyword package, and set the keyword in the
1949 * argument list, so that a function argument keyword
1950 * will reference the same object, and make comparison
1951 * simpler. */
1952 spec = LispCheckKeyword(CAR(spec));
1953 }
1954
1955 count = alist->keys.num_symbols;
1956 REALLOC_OBJECTS(alist->keys.keys, count + 1);
1957 REALLOC_OBJECTS(alist->keys.defaults, count + 1);
1958 REALLOC_OBJECTS(alist->keys.sforms, count + 1);
1959 REALLOC_OBJECTS(alist->keys.symbols, count + 1);
1960 alist->keys.symbols[count] = spec;
1961 alist->keys.defaults[count] = defval;
1962 alist->keys.sforms[count] = sform;
1963 alist->keys.keys[count] = akey;
1964 ++alist->keys.num_symbols;
1965 if (count == 0)
1966 *desc++ = 'k';
1967 alist->num_arguments += 1 + (sform != NULL);
1968 }
1969 else if (optional) {
1970 defval = default_value;
1971 sform = NULL;
1972
1973 if (!SYMBOLP(CAR(spec)))
1974 LispDestroy("%s %s: %s cannot be a %s argument name",
1975 fnames[type], name,
1976 STROBJ(CAR(spec)), types[type]);
1977 /* check if default value provided, and optionally a `svar' */
1978 else if (CDR(spec) != NIL && (!CONSP(CDR(spec)) ||
1979 (CDDR(spec) != NIL &&
1980 (!SYMBOLP(CAR(CDDR(spec))) ||
1981 CDR(CDDR(spec)) != NIL))))
1982 LispDestroy("%s %s: bad argument specification %s",
1983 fnames[type], name, STROBJ(spec));
1984 if (CONSP(CDR(spec))) {
1985 defval = CADR(spec);
1986 if (CONSP(CDDR(spec)))
1987 sform = CAR(CDDR(spec));
1988 }
1989 spec = CAR(spec);
1990
1991 count = alist->optionals.num_symbols;
1992 REALLOC_OBJECTS(alist->optionals.symbols, count + 1);
1993 REALLOC_OBJECTS(alist->optionals.defaults, count + 1);
1994 REALLOC_OBJECTS(alist->optionals.sforms, count + 1);
1995 alist->optionals.symbols[count] = spec;
1996 alist->optionals.defaults[count] = defval;
1997 alist->optionals.sforms[count] = sform;
1998 ++alist->optionals.num_symbols;
1999 if (count == 0)
2000 *desc++ = 'o';
2001 alist->num_arguments += 1 + (sform != NULL);
2002 }
2003
2004 /* Normal arguments cannot have default value */
2005 else
2006 LispDestroy("%s %s: syntax error parsing %s",
2007 fnames[type], name, STROBJ(spec));
2008 }
2009
2010 /* spec must be an atom, excluding keywords */
2011 else if (!SYMBOLP(spec) || KEYWORDP(spec))
2012 LispDestroy("%s %s: %s cannot be a %s argument",
2013 fnames[type], name, STROBJ(spec), types[type]);
2014 else {
2015 Atom_id atom = ATOMID(spec);
2016
2017 if (atom->value[0] == '&') {
2018 if (atom == Srest) {
2019 if (rest || aux || CDR(list) == NIL || !SYMBOLP(CADR(list))
2020 /* only &aux allowed after &rest */
2021 || (CDDR(list) != NIL && !SYMBOLP(CAR(CDDR(list))) &&
2022 ATOMID(CAR(CDDR(list))) != Saux))
2023 LispDestroy("%s %s: syntax error parsing %s",
2024 fnames[type], name, ATOMID(spec)->value);
2025 if (key)
2026 LispDestroy("%s %s: %s not allowed after %s",
2027 fnames[type], name, keys[IREST], keys[IKEY]);
2028 rest = 1;
2029 continue;
2030 }
2031
2032 else if (atom == Skey) {
2033 if (rest || aux)
2034 LispDestroy("%s %s: %s not allowed after %s",
2035 fnames[type], name, ATOMID(spec)->value,
2036 rest ? keys[IREST] : keys[IAUX]);
2037 key = 1;
2038 continue;
2039 }
2040
2041 else if (atom == Soptional) {
2042 if (rest || optional || aux || key)
2043 LispDestroy("%s %s: %s not allowed after %s",
2044 fnames[type], name, ATOMID(spec)->value,
2045 rest ? keys[IREST] :
2046 optional ?
2047 keys[IOPTIONAL] :
2048 aux ? keys[IAUX] : keys[IKEY]);
2049 optional = 1;
2050 continue;
2051 }
2052
2053 else if (atom == Saux) {
2054 /* &AUX must be the last keyword parameter */
2055 if (aux)
2056 LispDestroy("%s %s: syntax error parsing %s",
2057 fnames[type], name, ATOMID(spec)->value);
2058 else if (builtin)
2059 LispDestroy("builtin function cannot have &AUX arguments");
2060 aux = 1;
2061 continue;
2062 }
2063
2064 /* Untill more lambda-list keywords supported, don't allow
2065 * argument names starting with the '&' character */
2066 else
2067 LispDestroy("%s %s: %s not allowed/implemented",
2068 fnames[type], name, ATOMID(spec)->value);
2069 }
2070
2071 /* Add argument to alist */
2072 if (aux) {
2073 count = alist->auxs.num_symbols;
2074 REALLOC_OBJECTS(alist->auxs.symbols, count + 1);
2075 REALLOC_OBJECTS(alist->auxs.initials, count + 1);
2076 alist->auxs.symbols[count] = spec;
2077 alist->auxs.initials[count] = default_value;
2078 ++alist->auxs.num_symbols;
2079 if (count == 0)
2080 *desc++ = 'a';
2081 ++alist->num_arguments;
2082 }
2083 else if (rest) {
2084 alist->rest = spec;
2085 *desc++ = 'r';
2086 ++alist->num_arguments;
2087 }
2088 else if (key) {
2089 /* Add to keyword package, and set the keyword in the
2090 * argument list, so that a function argument keyword
2091 * will reference the same object, and make comparison
2092 * simpler. */
2093 spec = LispCheckKeyword(spec);
2094 count = alist->keys.num_symbols;
2095 REALLOC_OBJECTS(alist->keys.keys, count + 1);
2096 REALLOC_OBJECTS(alist->keys.defaults, count + 1);
2097 REALLOC_OBJECTS(alist->keys.sforms, count + 1);
2098 REALLOC_OBJECTS(alist->keys.symbols, count + 1);
2099 alist->keys.symbols[count] = spec;
2100 alist->keys.defaults[count] = default_value;
2101 alist->keys.sforms[count] = NULL;
2102 alist->keys.keys[count] = NULL;
2103 ++alist->keys.num_symbols;
2104 if (count == 0)
2105 *desc++ = 'k';
2106 ++alist->num_arguments;
2107 }
2108 else if (optional) {
2109 count = alist->optionals.num_symbols;
2110 REALLOC_OBJECTS(alist->optionals.symbols, count + 1);
2111 REALLOC_OBJECTS(alist->optionals.defaults, count + 1);
2112 REALLOC_OBJECTS(alist->optionals.sforms, count + 1);
2113 alist->optionals.symbols[count] = spec;
2114 alist->optionals.defaults[count] = default_value;
2115 alist->optionals.sforms[count] = NULL;
2116 ++alist->optionals.num_symbols;
2117 if (count == 0)
2118 *desc++ = 'o';
2119 ++alist->num_arguments;
2120 }
2121 else {
2122 count = alist->normals.num_symbols;
2123 REALLOC_OBJECTS(alist->normals.symbols, count + 1);
2124 alist->normals.symbols[count] = spec;
2125 ++alist->normals.num_symbols;
2126 if (count == 0)
2127 *desc++ = '.';
2128 ++alist->num_arguments;
2129 }
2130 }
2131 }
2132
2133 /* Check for dotted argument list */
2134 if (list != NIL)
2135 LispDestroy("%s %s: %s cannot end %s arguments",
2136 fnames[type], name, STROBJ(list), types[type]);
2137
2138 *desc = '\0';
2139 alist->description = LispGetAtomKey(description, 0)->value;
2140
2141 return (alist);
2142 }
2143
2144 void
LispAddBuiltinFunction(LispBuiltin * builtin)2145 LispAddBuiltinFunction(LispBuiltin *builtin)
2146 {
2147 static LispObj stream;
2148 static LispString string;
2149 static int first = 1;
2150 LispObj *name, *obj, *list, *cons, *code;
2151 LispAtom *atom;
2152 LispArgList *alist;
2153 int length = lisp__data.protect.length;
2154
2155 if (first) {
2156 stream.type = LispStream_t;
2157 stream.data.stream.source.string = &string;
2158 stream.data.stream.pathname = NIL;
2159 stream.data.stream.type = LispStreamString;
2160 stream.data.stream.readable = 1;
2161 stream.data.stream.writable = 0;
2162 string.output = 0;
2163 first = 0;
2164 }
2165 string.string = builtin->declaration;
2166 string.length = strlen(builtin->declaration);
2167 string.input = 0;
2168
2169 code = COD;
2170 LispPushInput(&stream);
2171 name = LispRead();
2172 list = cons = CONS(name, NIL);
2173 if (length + 1 >= lisp__data.protect.space)
2174 LispMoreProtects();
2175 lisp__data.protect.objects[lisp__data.protect.length++] = list;
2176 while ((obj = LispRead()) != NULL) {
2177 RPLACD(cons, CONS(obj, NIL));
2178 cons = CDR(cons);
2179 }
2180 LispPopInput(&stream);
2181
2182 atom = name->data.atom;
2183 alist = LispCheckArguments(builtin->type, CDR(list), atom->key->value, 1);
2184 builtin->symbol = CAR(list);
2185 LispSetAtomBuiltinProperty(atom, builtin, alist);
2186 LispUseArgList(alist);
2187
2188 /* Make function a extern symbol, unless told to not do so */
2189 if (!builtin->internal)
2190 LispExportSymbol(name);
2191
2192 lisp__data.protect.length = length;
2193 COD = code; /* LispRead protect data in COD */
2194 }
2195
2196 void
LispAllocSeg(LispObjSeg * seg,int cellcount)2197 LispAllocSeg(LispObjSeg *seg, int cellcount)
2198 {
2199 unsigned int i;
2200 LispObj **list, *obj;
2201
2202 DISABLE_INTERRUPTS();
2203 while (seg->nfree < cellcount) {
2204 if ((obj = (LispObj*)calloc(1, sizeof(LispObj) * segsize)) == NULL) {
2205 ENABLE_INTERRUPTS();
2206 LispDestroy("out of memory");
2207 }
2208 if ((list = (LispObj**)realloc(seg->objects,
2209 sizeof(LispObj*) * (seg->nsegs + 1))) == NULL) {
2210 free(obj);
2211 ENABLE_INTERRUPTS();
2212 LispDestroy("out of memory");
2213 }
2214 seg->objects = list;
2215 seg->objects[seg->nsegs] = obj;
2216
2217 seg->nfree += segsize;
2218 seg->nobjs += segsize;
2219 for (i = 1; i < segsize; i++, obj++) {
2220 /* Objects of type cons are the most used, save some time
2221 * by not setting it's type in LispNewCons. */
2222 obj->type = LispCons_t;
2223 CDR(obj) = obj + 1;
2224 }
2225 obj->type = LispCons_t;
2226 CDR(obj) = seg->freeobj;
2227 seg->freeobj = seg->objects[seg->nsegs];
2228 ++seg->nsegs;
2229 }
2230 #ifdef DEBUG
2231 LispMessage("gc: %d cell(s) allocated at %d segment(s)",
2232 seg->nobjs, seg->nsegs);
2233 #endif
2234 ENABLE_INTERRUPTS();
2235 }
2236
2237 static INLINE void
LispMark(register LispObj * object)2238 LispMark(register LispObj *object)
2239 {
2240 mark_again:
2241 switch (OBJECT_TYPE(object)) {
2242 case LispNil_t:
2243 case LispAtom_t:
2244 case LispFixnum_t:
2245 case LispSChar_t:
2246 case LispFunction_t:
2247 return;
2248 case LispLambda_t:
2249 if (OPAQUEP(object->data.lambda.name))
2250 object->data.lambda.name->mark = 1;
2251 object->mark = 1;
2252 LispMark(object->data.lambda.data);
2253 object = object->data.lambda.code;
2254 goto mark_cons;
2255 case LispQuote_t:
2256 case LispBackquote_t:
2257 case LispFunctionQuote_t:
2258 object->mark = 1;
2259 object = object->data.quote;
2260 goto mark_again;
2261 case LispPathname_t:
2262 object->mark = 1;
2263 object = object->data.pathname;
2264 goto mark_again;
2265 case LispComma_t:
2266 object->mark = 1;
2267 object = object->data.comma.eval;
2268 goto mark_again;
2269 case LispComplex_t:
2270 if (POINTERP(object->data.complex.real))
2271 object->data.complex.real->mark = 1;
2272 if (POINTERP(object->data.complex.imag))
2273 object->data.complex.imag->mark = 1;
2274 break;
2275 case LispCons_t:
2276 mark_cons:
2277 for (; CONSP(object) && !object->mark; object = CDR(object)) {
2278 object->mark = 1;
2279 switch (OBJECT_TYPE(CAR(object))) {
2280 case LispNil_t:
2281 case LispAtom_t:
2282 case LispFixnum_t:
2283 case LispSChar_t:
2284 case LispPackage_t: /* protected in gc */
2285 break;
2286 case LispInteger_t:
2287 case LispDFloat_t:
2288 case LispString_t:
2289 case LispRatio_t:
2290 case LispOpaque_t:
2291 case LispBignum_t:
2292 case LispBigratio_t:
2293 CAR(object)->mark = 1;
2294 break;
2295 default:
2296 LispMark(CAR(object));
2297 break;
2298 }
2299 }
2300 if (POINTERP(object) && !object->mark)
2301 goto mark_again;
2302 return;
2303 case LispArray_t:
2304 LispMark(object->data.array.list);
2305 object->mark = 1;
2306 object = object->data.array.dim;
2307 goto mark_cons;
2308 case LispStruct_t:
2309 object->mark = 1;
2310 object = object->data.struc.fields;
2311 goto mark_cons;
2312 case LispStream_t:
2313 mark_stream:
2314 LispMark(object->data.stream.pathname);
2315 if (object->data.stream.type == LispStreamPipe) {
2316 object->mark = 1;
2317 object = object->data.stream.source.program->errorp;
2318 goto mark_stream;
2319 }
2320 break;
2321 case LispRegex_t:
2322 object->data.regex.pattern->mark = 1;
2323 break;
2324 case LispBytecode_t:
2325 object->mark = 1;
2326 object = object->data.bytecode.code;
2327 goto mark_again;
2328 case LispHashTable_t: {
2329 unsigned long i;
2330 LispHashEntry *entry = object->data.hash.table->entries,
2331 *last = entry + object->data.hash.table->num_entries;
2332
2333 if (object->mark)
2334 return;
2335 object->mark = 1;
2336 for (; entry < last; entry++) {
2337 for (i = 0; i < entry->count; i++) {
2338 switch (OBJECT_TYPE(entry->keys[i])) {
2339 case LispNil_t:
2340 case LispAtom_t:
2341 case LispFixnum_t:
2342 case LispSChar_t:
2343 case LispFunction_t:
2344 case LispPackage_t:
2345 break;
2346 case LispInteger_t:
2347 case LispDFloat_t:
2348 case LispString_t:
2349 case LispRatio_t:
2350 case LispOpaque_t:
2351 case LispBignum_t:
2352 case LispBigratio_t:
2353 entry->keys[i]->mark = 1;
2354 break;
2355 default:
2356 LispMark(entry->keys[i]);
2357 break;
2358 }
2359 switch (OBJECT_TYPE(entry->values[i])) {
2360 case LispNil_t:
2361 case LispAtom_t:
2362 case LispFixnum_t:
2363 case LispSChar_t:
2364 case LispFunction_t:
2365 case LispPackage_t:
2366 break;
2367 case LispInteger_t:
2368 case LispDFloat_t:
2369 case LispString_t:
2370 case LispRatio_t:
2371 case LispOpaque_t:
2372 case LispBignum_t:
2373 case LispBigratio_t:
2374 entry->values[i]->mark = 1;
2375 break;
2376 default:
2377 LispMark(entry->values[i]);
2378 break;
2379 }
2380 }
2381 }
2382 } return;
2383 default:
2384 break;
2385 }
2386 object->mark = 1;
2387 }
2388
2389 static INLINE void
LispProt(register LispObj * object)2390 LispProt(register LispObj *object)
2391 {
2392 prot_again:
2393 switch (OBJECT_TYPE(object)) {
2394 case LispNil_t:
2395 case LispAtom_t:
2396 case LispFixnum_t:
2397 case LispSChar_t:
2398 case LispFunction_t:
2399 return;
2400 case LispLambda_t:
2401 if (OPAQUEP(object->data.lambda.name))
2402 object->data.lambda.name->prot = 1;
2403 object->prot = 1;
2404 LispProt(object->data.lambda.data);
2405 object = object->data.lambda.code;
2406 goto prot_cons;
2407 case LispQuote_t:
2408 case LispBackquote_t:
2409 case LispFunctionQuote_t:
2410 object->prot = 1;
2411 object = object->data.quote;
2412 goto prot_again;
2413 case LispPathname_t:
2414 object->prot = 1;
2415 object = object->data.pathname;
2416 goto prot_again;
2417 case LispComma_t:
2418 object->prot = 1;
2419 object = object->data.comma.eval;
2420 goto prot_again;
2421 case LispComplex_t:
2422 if (POINTERP(object->data.complex.real))
2423 object->data.complex.real->prot = 1;
2424 if (POINTERP(object->data.complex.imag))
2425 object->data.complex.imag->prot = 1;
2426 break;
2427 case LispCons_t:
2428 prot_cons:
2429 for (; CONSP(object) && !object->prot; object = CDR(object)) {
2430 object->prot = 1;
2431 switch (OBJECT_TYPE(CAR(object))) {
2432 case LispNil_t:
2433 case LispAtom_t:
2434 case LispFixnum_t:
2435 case LispSChar_t:
2436 case LispFunction_t:
2437 case LispPackage_t: /* protected in gc */
2438 break;
2439 case LispInteger_t:
2440 case LispDFloat_t:
2441 case LispString_t:
2442 case LispRatio_t:
2443 case LispOpaque_t:
2444 case LispBignum_t:
2445 case LispBigratio_t:
2446 CAR(object)->prot = 1;
2447 break;
2448 default:
2449 LispProt(CAR(object));
2450 break;
2451 }
2452 }
2453 if (POINTERP(object) && !object->prot)
2454 goto prot_again;
2455 return;
2456 case LispArray_t:
2457 LispProt(object->data.array.list);
2458 object->prot = 1;
2459 object = object->data.array.dim;
2460 goto prot_cons;
2461 case LispStruct_t:
2462 object->prot = 1;
2463 object = object->data.struc.fields;
2464 goto prot_cons;
2465 case LispStream_t:
2466 prot_stream:
2467 LispProt(object->data.stream.pathname);
2468 if (object->data.stream.type == LispStreamPipe) {
2469 object->prot = 1;
2470 object = object->data.stream.source.program->errorp;
2471 goto prot_stream;
2472 }
2473 break;
2474 case LispRegex_t:
2475 object->data.regex.pattern->prot = 1;
2476 break;
2477 case LispBytecode_t:
2478 object->prot = 1;
2479 object = object->data.bytecode.code;
2480 goto prot_again;
2481 case LispHashTable_t: {
2482 unsigned long i;
2483 LispHashEntry *entry = object->data.hash.table->entries,
2484 *last = entry + object->data.hash.table->num_entries;
2485
2486 if (object->prot)
2487 return;
2488 object->prot = 1;
2489 for (; entry < last; entry++) {
2490 for (i = 0; i < entry->count; i++) {
2491 switch (OBJECT_TYPE(entry->keys[i])) {
2492 case LispNil_t:
2493 case LispAtom_t:
2494 case LispFixnum_t:
2495 case LispSChar_t:
2496 case LispFunction_t:
2497 case LispPackage_t:
2498 break;
2499 case LispInteger_t:
2500 case LispDFloat_t:
2501 case LispString_t:
2502 case LispRatio_t:
2503 case LispOpaque_t:
2504 case LispBignum_t:
2505 case LispBigratio_t:
2506 entry->keys[i]->prot = 1;
2507 break;
2508 default:
2509 LispProt(entry->keys[i]);
2510 break;
2511 }
2512 switch (OBJECT_TYPE(entry->values[i])) {
2513 case LispNil_t:
2514 case LispAtom_t:
2515 case LispFixnum_t:
2516 case LispSChar_t:
2517 case LispFunction_t:
2518 case LispPackage_t:
2519 break;
2520 case LispInteger_t:
2521 case LispDFloat_t:
2522 case LispString_t:
2523 case LispRatio_t:
2524 case LispOpaque_t:
2525 case LispBignum_t:
2526 case LispBigratio_t:
2527 entry->values[i]->prot = 1;
2528 break;
2529 default:
2530 LispProt(entry->values[i]);
2531 break;
2532 }
2533 }
2534 }
2535 } return;
2536 default:
2537 break;
2538 }
2539 object->prot = 1;
2540 }
2541
2542 void
LispProtect(LispObj * key,LispObj * list)2543 LispProtect(LispObj *key, LispObj *list)
2544 {
2545 PRO = CONS(CONS(key, list), PRO);
2546 }
2547
2548 void
LispUProtect(LispObj * key,LispObj * list)2549 LispUProtect(LispObj *key, LispObj *list)
2550 {
2551 LispObj *prev, *obj;
2552
2553 for (prev = obj = PRO; obj != NIL; prev = obj, obj = CDR(obj))
2554 if (CAR(CAR(obj)) == key && CDR(CAR(obj)) == list) {
2555 if (obj == PRO)
2556 PRO = CDR(PRO);
2557 else
2558 CDR(prev) = CDR(obj);
2559 return;
2560 }
2561
2562 LispDestroy("no match for %s, at UPROTECT", STROBJ(key));
2563 }
2564
2565 static LispObj *
Lisp__New(LispObj * car,LispObj * cdr)2566 Lisp__New(LispObj *car, LispObj *cdr)
2567 {
2568 int cellcount;
2569 LispObj *obj;
2570
2571 Lisp__GC(car, cdr);
2572 #if 0
2573 lisp__data.gc.average = (objseg.nfree + lisp__data.gc.average) >> 1;
2574 if (lisp__data.gc.average < minfree) {
2575 if (lisp__data.gc.expandbits < 6)
2576 ++lisp__data.gc.expandbits;
2577 }
2578 else if (lisp__data.gc.expandbits)
2579 --lisp__data.gc.expandbits;
2580 /* For 32 bit computers, where sizeof(LispObj) == 16,
2581 * minfree is set to 1024, and expandbits limited to 6,
2582 * the maximum extra memory requested here should be 1Mb
2583 */
2584 cellcount = minfree << lisp__data.gc.expandbits;
2585 #else
2586 /* Try to keep at least 3 times more free cells than the de number
2587 * of used cells in the freelist, to amenize the cost of the gc time,
2588 * in the, currently, very simple gc strategy code. */
2589 cellcount = (objseg.nobjs - objseg.nfree) * 3;
2590 cellcount = cellcount + (minfree - (cellcount % minfree));
2591 #endif
2592
2593 if (objseg.freeobj == NIL || objseg.nfree < cellcount)
2594 LispAllocSeg(&objseg, cellcount);
2595
2596 obj = objseg.freeobj;
2597 objseg.freeobj = CDR(obj);
2598 --objseg.nfree;
2599
2600 return (obj);
2601 }
2602
2603 LispObj *
LispNew(LispObj * car,LispObj * cdr)2604 LispNew(LispObj *car, LispObj *cdr)
2605 {
2606 LispObj *obj = objseg.freeobj;
2607
2608 if (obj == NIL)
2609 obj = Lisp__New(car, cdr);
2610 else {
2611 objseg.freeobj = CDR(obj);
2612 --objseg.nfree;
2613 }
2614
2615 return (obj);
2616 }
2617
2618 LispObj *
LispNewAtom(const char * str,int intern)2619 LispNewAtom(const char *str, int intern)
2620 {
2621 LispObj *object;
2622 LispAtom *atom = LispDoGetAtom(str, 0);
2623
2624 if (atom->object) {
2625 if (intern && atom->package == NULL)
2626 atom->package = PACKAGE;
2627
2628 return (atom->object);
2629 }
2630
2631 if (atomseg.freeobj == NIL)
2632 LispAllocSeg(&atomseg, pagesize);
2633 object = atomseg.freeobj;
2634 atomseg.freeobj = CDR(object);
2635 --atomseg.nfree;
2636
2637 object->type = LispAtom_t;
2638 object->data.atom = atom;
2639 atom->object = object;
2640 if (intern)
2641 atom->package = PACKAGE;
2642
2643 return (object);
2644 }
2645
2646 LispObj *
LispNewStaticAtom(const char * str)2647 LispNewStaticAtom(const char *str)
2648 {
2649 LispObj *object;
2650 LispAtom *atom = LispDoGetAtom(str, 1);
2651
2652 object = LispNewSymbol(atom);
2653
2654 return (object);
2655 }
2656
2657 LispObj *
LispNewSymbol(LispAtom * atom)2658 LispNewSymbol(LispAtom *atom)
2659 {
2660 if (atom->object) {
2661 if (atom->package == NULL)
2662 atom->package = PACKAGE;
2663
2664 return (atom->object);
2665 }
2666 else {
2667 LispObj *symbol;
2668
2669 if (atomseg.freeobj == NIL)
2670 LispAllocSeg(&atomseg, pagesize);
2671 symbol = atomseg.freeobj;
2672 atomseg.freeobj = CDR(symbol);
2673 --atomseg.nfree;
2674
2675 symbol->type = LispAtom_t;
2676 symbol->data.atom = atom;
2677 atom->object = symbol;
2678 atom->package = PACKAGE;
2679
2680 return (symbol);
2681 }
2682 }
2683
2684 /* function representation is created on demand and never released,
2685 * even if the function is undefined and never defined again */
2686 LispObj *
LispNewFunction(LispObj * symbol)2687 LispNewFunction(LispObj *symbol)
2688 {
2689 LispObj *function;
2690
2691 if (symbol->data.atom->function)
2692 return (symbol->data.atom->function);
2693
2694 if (symbol->data.atom->package == NULL)
2695 symbol->data.atom->package = PACKAGE;
2696
2697 if (atomseg.freeobj == NIL)
2698 LispAllocSeg(&atomseg, pagesize);
2699 function = atomseg.freeobj;
2700 atomseg.freeobj = CDR(function);
2701 --atomseg.nfree;
2702
2703 function->type = LispFunction_t;
2704 function->data.atom = symbol->data.atom;
2705 symbol->data.atom->function = function;
2706
2707 return (function);
2708 }
2709
2710 /* symbol name representation is created on demand and never released */
2711 LispObj *
LispSymbolName(LispObj * symbol)2712 LispSymbolName(LispObj *symbol)
2713 {
2714 LispObj *name;
2715 LispAtom *atom = symbol->data.atom;
2716
2717 if (atom->name)
2718 return (atom->name);
2719
2720 if (atomseg.freeobj == NIL)
2721 LispAllocSeg(&atomseg, pagesize);
2722 name = atomseg.freeobj;
2723 atomseg.freeobj = CDR(name);
2724 --atomseg.nfree;
2725
2726 name->type = LispString_t;
2727 THESTR(name) = atom->key->value;
2728 STRLEN(name) = atom->key->length;
2729 name->data.string.writable = 0;
2730 atom->name = name;
2731
2732 return (name);
2733 }
2734
2735 LispObj *
LispNewFunctionQuote(LispObj * object)2736 LispNewFunctionQuote(LispObj *object)
2737 {
2738 LispObj *quote = LispNew(object, NIL);
2739
2740 quote->type = LispFunctionQuote_t;
2741 quote->data.quote = object;
2742
2743 return (quote);
2744 }
2745
2746 LispObj *
LispNewDFloat(double value)2747 LispNewDFloat(double value)
2748 {
2749 LispObj *dfloat = objseg.freeobj;
2750
2751 if (dfloat == NIL)
2752 dfloat = Lisp__New(NIL, NIL);
2753 else {
2754 objseg.freeobj = CDR(dfloat);
2755 --objseg.nfree;
2756 }
2757 dfloat->type = LispDFloat_t;
2758 dfloat->data.dfloat = value;
2759
2760 return (dfloat);
2761 }
2762
2763 LispObj *
LispNewString(const char * str,long length)2764 LispNewString(const char *str, long length)
2765 {
2766 char *cstring = LispMalloc(length + 1);
2767 memcpy(cstring, str, length);
2768 cstring[length] = '\0';
2769 return LispNewStringAlloced(cstring, length);
2770 }
2771
2772 LispObj *
LispNewStringAlloced(char * cstring,long length)2773 LispNewStringAlloced(char *cstring, long length)
2774 {
2775 LispObj *string = objseg.freeobj;
2776
2777 if (string == NIL)
2778 string = Lisp__New(NIL, NIL);
2779 else {
2780 objseg.freeobj = CDR(string);
2781 --objseg.nfree;
2782 }
2783 LispMused(cstring);
2784 string->type = LispString_t;
2785 THESTR(string) = cstring;
2786 STRLEN(string) = length;
2787 string->data.string.writable = 1;
2788
2789 return (string);
2790 }
2791
2792 LispObj *
LispNewComplex(LispObj * realpart,LispObj * imagpart)2793 LispNewComplex(LispObj *realpart, LispObj *imagpart)
2794 {
2795 LispObj *complexp = objseg.freeobj;
2796
2797 if (complexp == NIL)
2798 complexp = Lisp__New(realpart, imagpart);
2799 else {
2800 objseg.freeobj = CDR(complexp);
2801 --objseg.nfree;
2802 }
2803 complexp->type = LispComplex_t;
2804 complexp->data.complex.real = realpart;
2805 complexp->data.complex.imag = imagpart;
2806
2807 return (complexp);
2808 }
2809
2810 LispObj *
LispNewInteger(long integer)2811 LispNewInteger(long integer)
2812 {
2813 if (integer > MOST_POSITIVE_FIXNUM || integer < MOST_NEGATIVE_FIXNUM) {
2814 LispObj *object = objseg.freeobj;
2815
2816 if (object == NIL)
2817 object = Lisp__New(NIL, NIL);
2818 else {
2819 objseg.freeobj = CDR(object);
2820 --objseg.nfree;
2821 }
2822 object->type = LispInteger_t;
2823 object->data.integer = integer;
2824
2825 return (object);
2826 }
2827 return (FIXNUM(integer));
2828 }
2829
2830 LispObj *
LispNewRatio(long num,long den)2831 LispNewRatio(long num, long den)
2832 {
2833 LispObj *ratio = objseg.freeobj;
2834
2835 if (ratio == NIL)
2836 ratio = Lisp__New(NIL, NIL);
2837 else {
2838 objseg.freeobj = CDR(ratio);
2839 --objseg.nfree;
2840 }
2841 ratio->type = LispRatio_t;
2842 ratio->data.ratio.numerator = num;
2843 ratio->data.ratio.denominator = den;
2844
2845 return (ratio);
2846 }
2847
2848 LispObj *
LispNewVector(LispObj * objects)2849 LispNewVector(LispObj *objects)
2850 {
2851 GC_ENTER();
2852 long count;
2853 LispObj *array, *dimension;
2854
2855 for (count = 0, array = objects; CONSP(array); count++, array = CDR(array))
2856 ;
2857
2858 GC_PROTECT(objects);
2859 dimension = CONS(FIXNUM(count), NIL);
2860 array = LispNew(objects, dimension);
2861 array->type = LispArray_t;
2862 array->data.array.list = objects;
2863 array->data.array.dim = dimension;
2864 array->data.array.rank = 1;
2865 array->data.array.type = LispNil_t;
2866 array->data.array.zero = count == 0;
2867 GC_LEAVE();
2868
2869 return (array);
2870 }
2871
2872 LispObj *
LispNewQuote(LispObj * object)2873 LispNewQuote(LispObj *object)
2874 {
2875 LispObj *quote = LispNew(object, NIL);
2876
2877 quote->type = LispQuote_t;
2878 quote->data.quote = object;
2879
2880 return (quote);
2881 }
2882
2883 LispObj *
LispNewBackquote(LispObj * object)2884 LispNewBackquote(LispObj *object)
2885 {
2886 LispObj *backquote = LispNew(object, NIL);
2887
2888 backquote->type = LispBackquote_t;
2889 backquote->data.quote = object;
2890
2891 return (backquote);
2892 }
2893
2894 LispObj *
LispNewComma(LispObj * object,int atlist)2895 LispNewComma(LispObj *object, int atlist)
2896 {
2897 LispObj *comma = LispNew(object, NIL);
2898
2899 comma->type = LispComma_t;
2900 comma->data.comma.eval = object;
2901 comma->data.comma.atlist = atlist;
2902
2903 return (comma);
2904 }
2905
2906 LispObj *
LispNewCons(LispObj * car,LispObj * cdr)2907 LispNewCons(LispObj *car, LispObj *cdr)
2908 {
2909 LispObj *cons = objseg.freeobj;
2910
2911 if (cons == NIL)
2912 cons = Lisp__New(car, cdr);
2913 else {
2914 objseg.freeobj = CDR(cons);
2915 --objseg.nfree;
2916 }
2917 CAR(cons) = car;
2918 CDR(cons) = cdr;
2919
2920 return (cons);
2921 }
2922
2923 LispObj *
LispNewLambda(LispObj * name,LispObj * code,LispObj * data,LispFunType type)2924 LispNewLambda(LispObj *name, LispObj *code, LispObj *data, LispFunType type)
2925 {
2926 LispObj *fun = LispNew(data, code);
2927
2928 fun->type = LispLambda_t;
2929 fun->funtype = type;
2930 fun->data.lambda.name = name;
2931 fun->data.lambda.code = code;
2932 fun->data.lambda.data = data;
2933
2934 return (fun);
2935 }
2936
2937 LispObj *
LispNewStruct(LispObj * fields,LispObj * def)2938 LispNewStruct(LispObj *fields, LispObj *def)
2939 {
2940 LispObj *struc = LispNew(fields, def);
2941
2942 struc->type = LispStruct_t;
2943 struc->data.struc.fields = fields;
2944 struc->data.struc.def = def;
2945
2946 return (struc);
2947 }
2948
2949 LispObj *
LispNewOpaque(void * data,int type)2950 LispNewOpaque(void *data, int type)
2951 {
2952 LispObj *opaque = LispNew(NIL, NIL);
2953
2954 opaque->type = LispOpaque_t;
2955 opaque->data.opaque.data = data;
2956 opaque->data.opaque.type = type;
2957
2958 return (opaque);
2959 }
2960
2961 /* string argument must be static, or allocated */
2962 LispObj *
LispNewKeyword(const char * string)2963 LispNewKeyword(const char *string)
2964 {
2965 LispObj *keyword;
2966
2967 if (PACKAGE != lisp__data.keyword) {
2968 LispObj *savepackage;
2969 LispPackage *savepack;
2970
2971 /* Save package environment */
2972 savepackage = PACKAGE;
2973 savepack = lisp__data.pack;
2974
2975 /* Change package environment */
2976 PACKAGE = lisp__data.keyword;
2977 lisp__data.pack = lisp__data.key;
2978
2979 /* Create symbol in keyword package */
2980 keyword = LispNewStaticAtom(string);
2981
2982 /* Restore package environment */
2983 PACKAGE = savepackage;
2984 lisp__data.pack = savepack;
2985 }
2986 else
2987 /* Just create symbol in keyword package */
2988 keyword = LispNewStaticAtom(string);
2989
2990 /* Export keyword symbol */
2991 LispExportSymbol(keyword);
2992
2993 /* All keywords are constants */
2994 keyword->data.atom->constant = 1;
2995
2996 /* XXX maybe should bound the keyword to itself, but that would
2997 * require allocating a LispProperty structure for every keyword */
2998
2999 return (keyword);
3000 }
3001
3002 LispObj *
LispNewPathname(LispObj * obj)3003 LispNewPathname(LispObj *obj)
3004 {
3005 LispObj *path = LispNew(obj, NIL);
3006
3007 path->type = LispPathname_t;
3008 path->data.pathname = obj;
3009
3010 return (path);
3011 }
3012
3013 LispObj *
LispNewStringStream(const char * string,int flags,long length)3014 LispNewStringStream(const char *string, int flags, long length)
3015 {
3016 char *newstring = LispMalloc(length + 1);
3017 memcpy(newstring, string, length);
3018 newstring[length] = '\0';
3019
3020 return LispNewStringStreamAlloced(newstring, flags, length);
3021 }
3022
3023 LispObj *
LispNewStringStreamAlloced(char * string,int flags,long length)3024 LispNewStringStreamAlloced(char *string, int flags, long length)
3025 {
3026 LispObj *stream = LispNew(NIL, NIL);
3027
3028 SSTREAMP(stream) = LispCalloc(1, sizeof(LispString));
3029 SSTREAMP(stream)->string = string;
3030
3031 stream->type = LispStream_t;
3032
3033 SSTREAMP(stream)->length = length;
3034 LispMused(SSTREAMP(stream));
3035 LispMused(SSTREAMP(stream)->string);
3036 stream->data.stream.type = LispStreamString;
3037 stream->data.stream.readable = (flags & STREAM_READ) != 0;
3038 stream->data.stream.writable = (flags & STREAM_WRITE) != 0;
3039 SSTREAMP(stream)->space = length + 1;
3040
3041 stream->data.stream.pathname = NIL;
3042
3043 return (stream);
3044 }
3045
3046 LispObj *
LispNewFileStream(LispFile * file,LispObj * path,int flags)3047 LispNewFileStream(LispFile *file, LispObj *path, int flags)
3048 {
3049 LispObj *stream = LispNew(NIL, NIL);
3050
3051 stream->type = LispStream_t;
3052 FSTREAMP(stream) = file;
3053 stream->data.stream.pathname = path;
3054 stream->data.stream.type = LispStreamFile;
3055 stream->data.stream.readable = (flags & STREAM_READ) != 0;
3056 stream->data.stream.writable = (flags & STREAM_WRITE) != 0;
3057
3058 return (stream);
3059 }
3060
3061 LispObj *
LispNewPipeStream(LispPipe * program,LispObj * path,int flags)3062 LispNewPipeStream(LispPipe *program, LispObj *path, int flags)
3063 {
3064 LispObj *stream = LispNew(NIL, NIL);
3065
3066 stream->type = LispStream_t;
3067 PSTREAMP(stream) = program;
3068 stream->data.stream.pathname = path;
3069 stream->data.stream.type = LispStreamPipe;
3070 stream->data.stream.readable = (flags & STREAM_READ) != 0;
3071 stream->data.stream.writable = (flags & STREAM_WRITE) != 0;
3072
3073 return (stream);
3074 }
3075
3076 LispObj *
LispNewStandardStream(LispFile * file,LispObj * description,int flags)3077 LispNewStandardStream(LispFile *file, LispObj *description, int flags)
3078 {
3079 LispObj *stream = LispNew(NIL, NIL);
3080
3081 stream->type = LispStream_t;
3082 FSTREAMP(stream) = file;
3083 stream->data.stream.pathname = description;
3084 stream->data.stream.type = LispStreamStandard;
3085 stream->data.stream.readable = (flags & STREAM_READ) != 0;
3086 stream->data.stream.writable = (flags & STREAM_WRITE) != 0;
3087
3088 return (stream);
3089 }
3090
3091 LispObj *
LispNewBignum(mpi * bignum)3092 LispNewBignum(mpi *bignum)
3093 {
3094 LispObj *integer = LispNew(NIL, NIL);
3095
3096 integer->type = LispBignum_t;
3097 integer->data.mp.integer = bignum;
3098 LispMused(bignum->digs);
3099 LispMused(bignum);
3100
3101 return (integer);
3102 }
3103
3104 LispObj *
LispNewBigratio(mpr * bigratio)3105 LispNewBigratio(mpr *bigratio)
3106 {
3107 LispObj *ratio = LispNew(NIL, NIL);
3108
3109 ratio->type = LispBigratio_t;
3110 ratio->data.mp.ratio = bigratio;
3111 LispMused(mpr_num(bigratio)->digs);
3112 LispMused(mpr_den(bigratio)->digs);
3113 LispMused(bigratio);
3114
3115 return (ratio);
3116 }
3117
3118 /* name must be of type LispString_t */
3119 LispObj *
LispNewPackage(LispObj * name,LispObj * nicknames)3120 LispNewPackage(LispObj *name, LispObj *nicknames)
3121 {
3122 LispObj *package = LispNew(name, nicknames);
3123 LispPackage *pack = LispCalloc(1, sizeof(LispPackage));
3124
3125 package->type = LispPackage_t;
3126 package->data.package.name = name;
3127 package->data.package.nicknames = nicknames;
3128 package->data.package.package = pack;
3129
3130 package->data.package.package->atoms = hash_new(STRTBLSZ, NULL);
3131
3132 LispMused(pack);
3133
3134 return (package);
3135 }
3136
3137 LispObj *
LispSymbolFunction(LispObj * symbol)3138 LispSymbolFunction(LispObj *symbol)
3139 {
3140 LispAtom *atom = symbol->data.atom;
3141
3142 if ((atom->a_builtin &&
3143 atom->property->fun.builtin->type == LispFunction) ||
3144 (atom->a_function &&
3145 atom->property->fun.function->funtype == LispFunction) ||
3146 (atom->a_defstruct &&
3147 atom->property->structure.function != STRUCT_NAME) ||
3148 /* XXX currently bytecode is only generated for functions */
3149 atom->a_compiled)
3150 symbol = FUNCTION(symbol);
3151 else
3152 LispDestroy("SYMBOL-FUNCTION: %s is not a function", STROBJ(symbol));
3153
3154 return (symbol);
3155 }
3156
3157
3158 static INLINE LispObj *
LispGetVarPack(LispObj * symbol)3159 LispGetVarPack(LispObj *symbol)
3160 {
3161 LispAtom *atom;
3162
3163 atom = (LispAtom *)hash_get(lisp__data.pack->atoms,
3164 symbol->data.atom->key);
3165
3166 return (atom ? atom->object : NULL);
3167 }
3168
3169 /* package must be of type LispPackage_t */
3170 void
LispUsePackage(LispObj * package)3171 LispUsePackage(LispObj *package)
3172 {
3173 LispAtom *atom;
3174 LispPackage *pack;
3175 LispObj **pentry, **eentry;
3176
3177 /* Already using its own symbols... */
3178 if (package == PACKAGE)
3179 return;
3180
3181 /* Check if package not already in use-package list */
3182 for (pentry = lisp__data.pack->use.pairs,
3183 eentry = pentry + lisp__data.pack->use.length;
3184 pentry < eentry; pentry++)
3185 if (*pentry == package)
3186 return;
3187
3188 /* Remember this package is in the use-package list */
3189 if (lisp__data.pack->use.length + 1 >= lisp__data.pack->use.space) {
3190 LispObj **pairs = realloc(lisp__data.pack->use.pairs,
3191 (lisp__data.pack->use.space + 1) *
3192 sizeof(LispObj*));
3193
3194 if (pairs == NULL)
3195 LispDestroy("out of memory");
3196
3197 lisp__data.pack->use.pairs = pairs;
3198 ++lisp__data.pack->use.space;
3199 }
3200 lisp__data.pack->use.pairs[lisp__data.pack->use.length++] = package;
3201
3202 /* Import all extern symbols from package */
3203 pack = package->data.package.package;
3204
3205 /* Traverse atom list, searching for extern symbols */
3206 for (atom = (LispAtom *)hash_iter_first(pack->atoms);
3207 atom;
3208 atom = (LispAtom *)hash_iter_next(pack->atoms)) {
3209 if (atom->ext)
3210 LispImportSymbol(atom->object);
3211 }
3212 }
3213
3214 /* symbol must be of type LispAtom_t */
3215 void
LispImportSymbol(LispObj * symbol)3216 LispImportSymbol(LispObj *symbol)
3217 {
3218 int increment;
3219 LispAtom *atom;
3220 LispObj *current;
3221
3222 current = LispGetVarPack(symbol);
3223 if (current == NULL || current->data.atom->property == NOPROPERTY) {
3224 /* No conflicts */
3225
3226 if (symbol->data.atom->a_object) {
3227 /* If it is a bounded variable */
3228 if (lisp__data.pack->glb.length + 1 >= lisp__data.pack->glb.space)
3229 LispMoreGlobals(lisp__data.pack);
3230 lisp__data.pack->glb.pairs[lisp__data.pack->glb.length++] = symbol;
3231 }
3232
3233 /* Create copy of atom in current package */
3234 atom = LispDoGetAtom(ATOMID(symbol)->value, 0);
3235 /* Need to create a copy because if anything new is atached to the
3236 * property, the current package is the owner, not the previous one. */
3237
3238 /* And reference the same properties */
3239 atom->property = symbol->data.atom->property;
3240
3241 increment = 1;
3242 }
3243 else if (current->data.atom->property != symbol->data.atom->property) {
3244 /* Symbol already exists in the current package,
3245 * but does not reference the same variable */
3246 LispContinuable("Symbol %s already defined in package %s. Redefine?",
3247 ATOMID(symbol)->value, THESTR(PACKAGE->data.package.name));
3248
3249 atom = current->data.atom;
3250
3251 /* Continued from error, redefine variable */
3252 LispDecrementAtomReference(atom);
3253 atom->property = symbol->data.atom->property;
3254
3255 atom->a_object = atom->a_function = atom->a_builtin =
3256 atom->a_property = atom->a_defsetf = atom->a_defstruct = 0;
3257
3258 increment = 1;
3259 }
3260 else {
3261 /* Symbol is already available in the current package, just update */
3262 atom = current->data.atom;
3263
3264 increment = 0;
3265 }
3266
3267 /* If importing an important system variable */
3268 atom->watch = symbol->data.atom->watch;
3269
3270 /* Update constant flag */
3271 atom->constant = symbol->data.atom->constant;
3272
3273 /* Set home-package and unique-atom associated with symbol */
3274 atom->package = symbol->data.atom->package;
3275 atom->object = symbol->data.atom->object;
3276
3277 if (symbol->data.atom->a_object)
3278 atom->a_object = 1;
3279 if (symbol->data.atom->a_function)
3280 atom->a_function = 1;
3281 else if (symbol->data.atom->a_builtin)
3282 atom->a_builtin = 1;
3283 else if (symbol->data.atom->a_compiled)
3284 atom->a_compiled = 1;
3285 if (symbol->data.atom->a_property)
3286 atom->a_property = 1;
3287 if (symbol->data.atom->a_defsetf)
3288 atom->a_defsetf = 1;
3289 if (symbol->data.atom->a_defstruct)
3290 atom->a_defstruct = 1;
3291
3292 if (increment)
3293 /* Increase reference count, more than one package using the symbol */
3294 LispIncrementAtomReference(symbol->data.atom);
3295 }
3296
3297 /* symbol must be of type LispAtom_t */
3298 void
LispExportSymbol(LispObj * symbol)3299 LispExportSymbol(LispObj *symbol)
3300 {
3301 /* This does not automatically export symbols to another package using
3302 * the symbols of the current package */
3303 symbol->data.atom->ext = 1;
3304 }
3305
3306 #ifdef __GNUC__
3307 LispObj *
LispGetVar(LispObj * atom)3308 LispGetVar(LispObj *atom)
3309 {
3310 return (LispDoGetVar(atom));
3311 }
3312
3313 static INLINE LispObj *
LispDoGetVar(LispObj * atom)3314 LispDoGetVar(LispObj *atom)
3315 #else
3316 #define LispDoGetVar LispGetVar
3317 LispObj *
3318 LispGetVar(LispObj *atom)
3319 #endif
3320 {
3321 LispAtom *name;
3322 int i, base, offset;
3323 Atom_id id;
3324
3325 name = atom->data.atom;
3326 if (name->constant && name->package == lisp__data.keyword)
3327 return (atom);
3328
3329 /* XXX offset should be stored elsewhere, it is unique, like the string
3330 * pointer. Unless a multi-thread interface is implemented (where
3331 * multiple stacks would be required, the offset value should be
3332 * stored with the string, so that a few cpu cicles could be saved
3333 * by initializing the value to -1, and only searching for the symbol
3334 * binding if it is not -1, and if no binding is found, because the
3335 * lexical scope was left, reset offset to -1. */
3336 offset = name->offset;
3337 id = name->key;
3338 base = lisp__data.env.lex;
3339 i = lisp__data.env.head - 1;
3340
3341 if (offset <= i && (offset >= base || name->dyn) &&
3342 lisp__data.env.names[offset] == id)
3343 return (lisp__data.env.values[offset]);
3344
3345 for (; i >= base; i--)
3346 if (lisp__data.env.names[i] == id) {
3347 name->offset = i;
3348
3349 return (lisp__data.env.values[i]);
3350 }
3351
3352 if (name->dyn) {
3353 /* Keep searching as maybe a rebound dynamic variable */
3354 for (; i >= 0; i--)
3355 if (lisp__data.env.names[i] == id) {
3356 name->offset = i;
3357
3358 return (lisp__data.env.values[i]);
3359 }
3360
3361 if (name->a_object) {
3362 /* Check for a symbol defined as special, but not yet bound. */
3363 if (name->property->value == UNBOUND)
3364 return (NULL);
3365
3366 return (name->property->value);
3367 }
3368 }
3369
3370 return (name->a_object ? name->property->value : NULL);
3371 }
3372
3373 #ifdef DEBUGGER
3374 /* Same code as LispDoGetVar, but returns the address of the pointer to
3375 * the object value. Used only by the debugger */
3376 void *
LispGetVarAddr(LispObj * atom)3377 LispGetVarAddr(LispObj *atom)
3378 {
3379 LispAtom *name;
3380 int i, base;
3381 Atom_id id;
3382
3383 name = atom->data.atom;
3384 if (name->constant && name->package == lisp__data.keyword)
3385 return (&atom);
3386
3387 id = name->string;
3388
3389 i = lisp__data.env.head - 1;
3390 for (base = lisp__data.env.lex; i >= base; i--)
3391 if (lisp__data.env.names[i] == id)
3392 return (&(lisp__data.env.values[i]));
3393
3394 if (name->dyn) {
3395 for (; i >= 0; i--)
3396 if (lisp__data.env.names[i] == id)
3397 return (&(lisp__data.env.values[i]));
3398
3399 if (name->a_object) {
3400 /* Check for a symbol defined as special, but not yet bound */
3401 if (name->property->value == UNBOUND)
3402 return (NULL);
3403
3404 return (&(name->property->value));
3405 }
3406 }
3407
3408 return (name->a_object ? &(name->property->value) : NULL);
3409 }
3410 #endif
3411
3412 /* Only removes global variables. To be called by makunbound
3413 * Local variables are unbounded once their block is closed anyway.
3414 */
3415 void
LispUnsetVar(LispObj * atom)3416 LispUnsetVar(LispObj *atom)
3417 {
3418 LispAtom *name = atom->data.atom;
3419
3420 if (name->package) {
3421 int i;
3422 LispPackage *pack = name->package->data.package.package;
3423
3424 for (i = pack->glb.length - 1; i > 0; i--)
3425 if (pack->glb.pairs[i] == atom) {
3426 LispRemAtomObjectProperty(name);
3427 --pack->glb.length;
3428 if (i < pack->glb.length)
3429 memmove(pack->glb.pairs + i, pack->glb.pairs + i + 1,
3430 sizeof(LispObj*) * (pack->glb.length - i));
3431
3432 /* unset hint about dynamically binded variable */
3433 if (name->dyn)
3434 name->dyn = 0;
3435 break;
3436 }
3437 }
3438 }
3439
3440 LispObj *
LispAddVar(LispObj * atom,LispObj * obj)3441 LispAddVar(LispObj *atom, LispObj *obj)
3442 {
3443 if (lisp__data.env.length >= lisp__data.env.space)
3444 LispMoreEnvironment();
3445
3446 LispDoAddVar(atom, obj);
3447
3448 return (obj);
3449 }
3450
3451 static INLINE void
LispDoAddVar(LispObj * symbol,LispObj * value)3452 LispDoAddVar(LispObj *symbol, LispObj *value)
3453 {
3454 LispAtom *atom = symbol->data.atom;
3455
3456 atom->offset = lisp__data.env.length;
3457 lisp__data.env.values[lisp__data.env.length] = value;
3458 lisp__data.env.names[lisp__data.env.length++] = atom->key;
3459 }
3460
3461 LispObj *
LispSetVar(LispObj * atom,LispObj * obj)3462 LispSetVar(LispObj *atom, LispObj *obj)
3463 {
3464 LispPackage *pack;
3465 LispAtom *name;
3466 int i, base, offset;
3467 Atom_id id;
3468
3469 name = atom->data.atom;
3470 offset = name->offset;
3471 id = name->key;
3472 base = lisp__data.env.lex;
3473 i = lisp__data.env.head - 1;
3474
3475 if (offset <= i && (offset >= base || name->dyn) &&
3476 lisp__data.env.names[offset] == id)
3477 return (lisp__data.env.values[offset] = obj);
3478
3479 for (; i >= base; i--)
3480 if (lisp__data.env.names[i] == id) {
3481 name->offset = i;
3482
3483 return (lisp__data.env.values[i] = obj);
3484 }
3485
3486 if (name->dyn) {
3487 for (; i >= 0; i--)
3488 if (lisp__data.env.names[i] == id)
3489 return (lisp__data.env.values[i] = obj);
3490
3491 if (name->watch) {
3492 LispSetAtomObjectProperty(name, obj);
3493
3494 return (obj);
3495 }
3496
3497 return (SETVALUE(name, obj));
3498 }
3499
3500 if (name->a_object) {
3501 if (name->watch) {
3502 LispSetAtomObjectProperty(name, obj);
3503
3504 return (obj);
3505 }
3506
3507 return (SETVALUE(name, obj));
3508 }
3509
3510 LispSetAtomObjectProperty(name, obj);
3511
3512 pack = name->package->data.package.package;
3513 if (pack->glb.length >= pack->glb.space)
3514 LispMoreGlobals(pack);
3515
3516 pack->glb.pairs[pack->glb.length++] = atom;
3517
3518 return (obj);
3519 }
3520
3521 void
LispProclaimSpecial(LispObj * atom,LispObj * value,LispObj * doc)3522 LispProclaimSpecial(LispObj *atom, LispObj *value, LispObj *doc)
3523 {
3524 int i = 0, dyn, glb;
3525 LispAtom *name;
3526 LispPackage *pack;
3527
3528 glb = 0;
3529 name = atom->data.atom;
3530 pack = name->package->data.package.package;
3531 dyn = name->dyn;
3532
3533 if (!dyn) {
3534 /* Note: don't check if a local variable already is using the symbol */
3535 for (i = pack->glb.length - 1; i >= 0; i--)
3536 if (pack->glb.pairs[i] == atom) {
3537 glb = 1;
3538 break;
3539 }
3540 }
3541
3542 if (dyn) {
3543 if (name->property->value == UNBOUND && value)
3544 /* if variable was just made special, but not bounded */
3545 LispSetAtomObjectProperty(name, value);
3546 }
3547 else if (glb)
3548 /* Already a global variable, but not marked as special.
3549 * Set hint about dynamically binded variable. */
3550 name->dyn = 1;
3551 else {
3552 /* create new special variable */
3553 LispSetAtomObjectProperty(name, value ? value : UNBOUND);
3554
3555 if (pack->glb.length >= pack->glb.space)
3556 LispMoreGlobals(pack);
3557
3558 pack->glb.pairs[pack->glb.length] = atom;
3559 ++pack->glb.length;
3560 /* set hint about possibly dynamically binded variable */
3561 name->dyn = 1;
3562 }
3563
3564 if (doc != NIL)
3565 LispAddDocumentation(atom, doc, LispDocVariable);
3566 }
3567
3568 void
LispDefconstant(LispObj * atom,LispObj * value,LispObj * doc)3569 LispDefconstant(LispObj *atom, LispObj *value, LispObj *doc)
3570 {
3571 int i;
3572 LispAtom *name = atom->data.atom;
3573 LispPackage *pack = name->package->data.package.package;
3574
3575 /* Unset hint about dynamically binded variable, if set. */
3576 name->dyn = 0;
3577
3578 /* Check if variable is bounded as a global variable */
3579 for (i = pack->glb.length - 1; i >= 0; i--)
3580 if (pack->glb.pairs[i] == atom)
3581 break;
3582
3583 if (i < 0) {
3584 /* Not a global variable */
3585 if (pack->glb.length >= pack->glb.space)
3586 LispMoreGlobals(pack);
3587
3588 pack->glb.pairs[pack->glb.length] = atom;
3589 ++pack->glb.length;
3590 }
3591
3592 /* If already a constant variable */
3593 if (name->constant && name->a_object && name->property->value != value)
3594 LispWarning("constant %s is being redefined", STROBJ(atom));
3595 else
3596 name->constant = 1;
3597
3598 /* Set constant value */
3599 LispSetAtomObjectProperty(name, value);
3600
3601 if (doc != NIL)
3602 LispAddDocumentation(atom, doc, LispDocVariable);
3603 }
3604
3605 void
LispAddDocumentation(LispObj * symbol,LispObj * documentation,LispDocType_t type)3606 LispAddDocumentation(LispObj *symbol, LispObj *documentation, LispDocType_t type)
3607 {
3608 int length;
3609 char *string;
3610 LispAtom *atom;
3611 LispObj *object;
3612
3613 if (!SYMBOLP(symbol) || !STRINGP(documentation))
3614 LispDestroy("DOCUMENTATION: invalid argument");
3615
3616 atom = symbol->data.atom;
3617 if (atom->documentation[type])
3618 LispRemDocumentation(symbol, type);
3619
3620 /* allocate documentation in atomseg */
3621 if (atomseg.freeobj == NIL)
3622 LispAllocSeg(&atomseg, pagesize);
3623 length = STRLEN(documentation);
3624 string = LispMalloc(length);
3625 memcpy(string, THESTR(documentation), length);
3626 string[length] = '\0';
3627 object = atomseg.freeobj;
3628 atomseg.freeobj = CDR(object);
3629 --atomseg.nfree;
3630
3631 object->type = LispString_t;
3632 THESTR(object) = string;
3633 STRLEN(object) = length;
3634 object->data.string.writable = 0;
3635 atom->documentation[type] = object;
3636 LispMused(string);
3637 }
3638
3639 void
LispRemDocumentation(LispObj * symbol,LispDocType_t type)3640 LispRemDocumentation(LispObj *symbol, LispDocType_t type)
3641 {
3642 LispAtom *atom;
3643
3644 if (!SYMBOLP(symbol))
3645 LispDestroy("DOCUMENTATION: invalid argument");
3646
3647 atom = symbol->data.atom;
3648 if (atom->documentation[type]) {
3649 /* reclaim object to atomseg */
3650 free(THESTR(atom->documentation[type]));
3651 CDR(atom->documentation[type]) = atomseg.freeobj;
3652 atomseg.freeobj = atom->documentation[type];
3653 atom->documentation[type] = NULL;
3654 ++atomseg.nfree;
3655 }
3656 }
3657
3658 LispObj *
LispGetDocumentation(LispObj * symbol,LispDocType_t type)3659 LispGetDocumentation(LispObj *symbol, LispDocType_t type)
3660 {
3661 LispAtom *atom;
3662
3663 if (!SYMBOLP(symbol))
3664 LispDestroy("DOCUMENTATION: invalid argument");
3665
3666 atom = symbol->data.atom;
3667
3668 return (atom->documentation[type] ? atom->documentation[type] : NIL);
3669 }
3670
3671 LispObj *
LispReverse(LispObj * list)3672 LispReverse(LispObj *list)
3673 {
3674 LispObj *tmp, *res = NIL;
3675
3676 while (list != NIL) {
3677 tmp = CDR(list);
3678 CDR(list) = res;
3679 res = list;
3680 list = tmp;
3681 }
3682
3683 return (res);
3684 }
3685
3686 LispBlock *
LispBeginBlock(LispObj * tag,LispBlockType type)3687 LispBeginBlock(LispObj *tag, LispBlockType type)
3688 {
3689 LispBlock *block;
3690 unsigned blevel = lisp__data.block.block_level + 1;
3691
3692 if (blevel > lisp__data.block.block_size) {
3693 LispBlock **blk;
3694
3695 if (blevel > MAX_STACK_DEPTH)
3696 LispDestroy("stack overflow");
3697
3698 DISABLE_INTERRUPTS();
3699 blk = realloc(lisp__data.block.block, sizeof(LispBlock*) * (blevel + 1));
3700
3701 block = NULL;
3702 if (blk == NULL || (block = malloc(sizeof(LispBlock))) == NULL) {
3703 ENABLE_INTERRUPTS();
3704 LispDestroy("out of memory");
3705 }
3706 lisp__data.block.block = blk;
3707 lisp__data.block.block[lisp__data.block.block_size] = block;
3708 lisp__data.block.block_size = blevel;
3709 ENABLE_INTERRUPTS();
3710 }
3711 block = lisp__data.block.block[lisp__data.block.block_level];
3712 if (type == LispBlockCatch && !CONSTANTP(tag)) {
3713 tag = EVAL(tag);
3714 lisp__data.protect.objects[lisp__data.protect.length++] = tag;
3715 }
3716 block->type = type;
3717 block->tag = tag;
3718 block->stack = lisp__data.stack.length;
3719 block->protect = lisp__data.protect.length;
3720 block->block_level = lisp__data.block.block_level;
3721
3722 lisp__data.block.block_level = blevel;
3723
3724 #ifdef DEBUGGER
3725 if (lisp__data.debugging) {
3726 block->debug_level = lisp__data.debug_level;
3727 block->debug_step = lisp__data.debug_step;
3728 }
3729 #endif
3730
3731 return (block);
3732 }
3733
3734 void
LispEndBlock(LispBlock * block)3735 LispEndBlock(LispBlock *block)
3736 {
3737 lisp__data.protect.length = block->protect;
3738 lisp__data.block.block_level = block->block_level;
3739
3740 #ifdef DEBUGGER
3741 if (lisp__data.debugging) {
3742 if (lisp__data.debug_level >= block->debug_level) {
3743 while (lisp__data.debug_level > block->debug_level) {
3744 DBG = CDR(DBG);
3745 --lisp__data.debug_level;
3746 }
3747 }
3748 lisp__data.debug_step = block->debug_step;
3749 }
3750 #endif
3751 }
3752
3753 void
LispBlockUnwind(LispBlock * block)3754 LispBlockUnwind(LispBlock *block)
3755 {
3756 LispBlock *unwind;
3757 int blevel = lisp__data.block.block_level;
3758
3759 while (blevel > 0) {
3760 unwind = lisp__data.block.block[--blevel];
3761 if (unwind->type == LispBlockProtect) {
3762 BLOCKJUMP(unwind);
3763 }
3764 if (unwind == block)
3765 /* jump above unwind block */
3766 break;
3767 }
3768 }
3769
3770 static LispObj *
LispEvalBackquoteObject(LispObj * argument,int list,int quote)3771 LispEvalBackquoteObject(LispObj *argument, int list, int quote)
3772 {
3773 LispObj *result = argument, *object;
3774
3775 if (!POINTERP(argument))
3776 return (argument);
3777
3778 else if (XCOMMAP(argument)) {
3779 /* argument may need to be evaluated */
3780
3781 int atlist;
3782
3783 if (!list && argument->data.comma.atlist)
3784 /* cannot append, not in a list */
3785 LispDestroy("EVAL: ,@ only allowed on lists");
3786
3787 --quote;
3788 if (quote < 0)
3789 LispDestroy("EVAL: comma outside of backquote");
3790
3791 result = object = argument->data.comma.eval;
3792 atlist = COMMAP(object) && object->data.comma.atlist;
3793
3794 if (POINTERP(result) && (XCOMMAP(result) || XBACKQUOTEP(result)))
3795 /* nested commas, reduce 1 level, or backquote,
3796 * don't call LispEval or quote argument will be reset */
3797 result = LispEvalBackquoteObject(object, 0, quote);
3798
3799 else if (quote == 0)
3800 /* just evaluate it */
3801 result = EVAL(result);
3802
3803 if (quote != 0)
3804 result = result == object ? argument : COMMA(result, atlist);
3805 }
3806
3807 else if (XBACKQUOTEP(argument)) {
3808 object = argument->data.quote;
3809
3810 result = LispEvalBackquote(object, quote + 1);
3811 if (quote)
3812 result = result == object ? argument : BACKQUOTE(result);
3813 }
3814
3815 else if (XQUOTEP(argument) && POINTERP(argument->data.quote) &&
3816 (XCOMMAP(argument->data.quote) ||
3817 XBACKQUOTEP(argument->data.quote) ||
3818 XCONSP(argument->data.quote))) {
3819 /* ensures `',sym to be the same as `(quote ,sym) */
3820 object = argument->data.quote;
3821
3822 result = LispEvalBackquote(argument->data.quote, quote);
3823 result = result == object ? argument : QUOTE(result);
3824 }
3825
3826 return (result);
3827 }
3828
3829 LispObj *
LispEvalBackquote(LispObj * argument,int quote)3830 LispEvalBackquote(LispObj *argument, int quote)
3831 {
3832 int protect;
3833 LispObj *result, *object, *cons, *cdr;
3834
3835 if (!CONSP(argument))
3836 return (LispEvalBackquoteObject(argument, 0, quote));
3837
3838 result = cdr = NIL;
3839 protect = lisp__data.protect.length;
3840
3841 /* always generate a new list for the result, even if nothing
3842 * is evaluated. It is not expected to use backqoutes when
3843 * not required. */
3844
3845 /* reserve a GC protected slot for the result */
3846 if (protect + 1 >= lisp__data.protect.space)
3847 LispMoreProtects();
3848 lisp__data.protect.objects[lisp__data.protect.length++] = NIL;
3849
3850 for (cons = argument; ; cons = CDR(cons)) {
3851 /* if false, last argument, and if cons is not NIL, a dotted list */
3852 int list = CONSP(cons), insert;
3853
3854 if (list)
3855 object = CAR(cons);
3856 else
3857 object = cons;
3858
3859 if (COMMAP(object))
3860 /* need to insert list elements in result, not just cons it? */
3861 insert = object->data.comma.atlist;
3862 else
3863 insert = 0;
3864
3865 /* evaluate object, if required */
3866 if (CONSP(object))
3867 object = LispEvalBackquote(object, quote);
3868 else
3869 object = LispEvalBackquoteObject(object, insert, quote);
3870
3871 if (result == NIL) {
3872 /* if starting result list */
3873 if (!insert) {
3874 if (list)
3875 result = cdr = CONS(object, NIL);
3876 else
3877 result = cdr = object;
3878 /* gc protect result */
3879 lisp__data.protect.objects[protect] = result;
3880 }
3881 else {
3882 if (!CONSP(object)) {
3883 result = cdr = object;
3884 /* gc protect result */
3885 lisp__data.protect.objects[protect] = result;
3886 }
3887 else {
3888 result = cdr = CONS(CAR(object), NIL);
3889 /* gc protect result */
3890 lisp__data.protect.objects[protect] = result;
3891
3892 /* add remaining elements to result */
3893 for (object = CDR(object);
3894 CONSP(object);
3895 object = CDR(object)) {
3896 RPLACD(cdr, CONS(CAR(object), NIL));
3897 cdr = CDR(cdr);
3898 }
3899 if (object != NIL) {
3900 /* object was a dotted list */
3901 RPLACD(cdr, object);
3902 cdr = CDR(cdr);
3903 }
3904 }
3905 }
3906 }
3907 else {
3908 if (!CONSP(cdr))
3909 LispDestroy("EVAL: cannot append to %s", STROBJ(cdr));
3910
3911 if (!insert) {
3912 if (list) {
3913 RPLACD(cdr, CONS(object, NIL));
3914 cdr = CDR(cdr);
3915 }
3916 else {
3917 RPLACD(cdr, object);
3918 cdr = object;
3919 }
3920 }
3921 else {
3922 if (!CONSP(object)) {
3923 RPLACD(cdr, object);
3924 /* if object is NIL, it is a empty list appended, not
3925 * creating a dotted list. */
3926 if (object != NIL)
3927 cdr = object;
3928 }
3929 else {
3930 for (; CONSP(object); object = CDR(object)) {
3931 RPLACD(cdr, CONS(CAR(object), NIL));
3932 cdr = CDR(cdr);
3933 }
3934 if (object != NIL) {
3935 /* object was a dotted list */
3936 RPLACD(cdr, object);
3937 cdr = CDR(cdr);
3938 }
3939 }
3940 }
3941 }
3942
3943 /* if last argument list element processed */
3944 if (!list)
3945 break;
3946 }
3947
3948 lisp__data.protect.length = protect;
3949
3950 return (result);
3951 }
3952
3953 void
LispMoreEnvironment(void)3954 LispMoreEnvironment(void)
3955 {
3956 Atom_id *names;
3957 LispObj **values;
3958
3959 DISABLE_INTERRUPTS();
3960 names = realloc(lisp__data.env.names,
3961 (lisp__data.env.space + 256) * sizeof(Atom_id));
3962 if (names != NULL) {
3963 values = realloc(lisp__data.env.values,
3964 (lisp__data.env.space + 256) * sizeof(LispObj*));
3965 if (values != NULL) {
3966 lisp__data.env.names = names;
3967 lisp__data.env.values = values;
3968 lisp__data.env.space += 256;
3969 ENABLE_INTERRUPTS();
3970 return;
3971 }
3972 else
3973 free(names);
3974 }
3975 ENABLE_INTERRUPTS();
3976 LispDestroy("out of memory");
3977 }
3978
3979 void
LispMoreStack(void)3980 LispMoreStack(void)
3981 {
3982 LispObj **values;
3983
3984 DISABLE_INTERRUPTS();
3985 values = realloc(lisp__data.stack.values,
3986 (lisp__data.stack.space + 256) * sizeof(LispObj*));
3987 if (values == NULL) {
3988 ENABLE_INTERRUPTS();
3989 LispDestroy("out of memory");
3990 }
3991 lisp__data.stack.values = values;
3992 lisp__data.stack.space += 256;
3993 ENABLE_INTERRUPTS();
3994 }
3995
3996 void
LispMoreGlobals(LispPackage * pack)3997 LispMoreGlobals(LispPackage *pack)
3998 {
3999 LispObj **pairs;
4000
4001 DISABLE_INTERRUPTS();
4002 pairs = realloc(pack->glb.pairs,
4003 (pack->glb.space + 256) * sizeof(LispObj*));
4004 if (pairs == NULL) {
4005 ENABLE_INTERRUPTS();
4006 LispDestroy("out of memory");
4007 }
4008 pack->glb.pairs = pairs;
4009 pack->glb.space += 256;
4010 ENABLE_INTERRUPTS();
4011 }
4012
4013 void
LispMoreProtects(void)4014 LispMoreProtects(void)
4015 {
4016 LispObj **objects;
4017
4018 DISABLE_INTERRUPTS();
4019 objects = realloc(lisp__data.protect.objects,
4020 (lisp__data.protect.space + 256) * sizeof(LispObj*));
4021 if (objects == NULL) {
4022 ENABLE_INTERRUPTS();
4023 LispDestroy("out of memory");
4024 }
4025 lisp__data.protect.objects = objects;
4026 lisp__data.protect.space += 256;
4027 ENABLE_INTERRUPTS();
4028 }
4029
4030 static int
LispMakeEnvironment(LispArgList * alist,LispObj * values,LispObj * name,int eval,int builtin)4031 LispMakeEnvironment(LispArgList *alist, LispObj *values,
4032 LispObj *name, int eval, int builtin)
4033 {
4034 char *desc;
4035 int i, count, base;
4036 LispObj **symbols, **defaults, **sforms;
4037
4038 #define BUILTIN_ARGUMENT(value) \
4039 lisp__data.stack.values[lisp__data.stack.length++] = value
4040
4041 /* If the index value is from register variables, this
4042 * can save some cpu time. Useful for normal arguments
4043 * that are the most common, and thus the ones that
4044 * consume more time in LispMakeEnvironment. */
4045 #define BUILTIN_NO_EVAL_ARGUMENT(index, value) \
4046 lisp__data.stack.values[index] = value
4047
4048 #define NORMAL_ARGUMENT(symbol, value) \
4049 LispDoAddVar(symbol, value)
4050
4051 if (builtin) {
4052 base = lisp__data.stack.length;
4053 if (base + alist->num_arguments > lisp__data.stack.space) {
4054 do
4055 LispMoreStack();
4056 while (base + alist->num_arguments > lisp__data.stack.space);
4057 }
4058 }
4059 else {
4060 base = lisp__data.env.length;
4061 if (base + alist->num_arguments > lisp__data.env.space) {
4062 do
4063 LispMoreEnvironment();
4064 while (base + alist->num_arguments > lisp__data.env.space);
4065 }
4066 }
4067
4068 desc = alist->description;
4069 switch (*desc++) {
4070 case '.':
4071 goto normal_label;
4072 case 'o':
4073 goto optional_label;
4074 case 'k':
4075 goto key_label;
4076 case 'r':
4077 goto rest_label;
4078 case 'a':
4079 goto aux_label;
4080 default:
4081 goto done_label;
4082 }
4083
4084
4085 /* Code below is done in several almost identical loops, to avoid
4086 * checking the value of the arguments eval and builtin too much times */
4087
4088
4089 /* Normal arguments */
4090 normal_label:
4091 i = 0;
4092 count = alist->normals.num_symbols;
4093 if (builtin) {
4094 if (eval) {
4095 for (; i < count && CONSP(values); i++, values = CDR(values)) {
4096 BUILTIN_ARGUMENT(EVAL(CAR(values)));
4097 }
4098 }
4099 else {
4100 for (; i < count && CONSP(values); i++, values = CDR(values)) {
4101 BUILTIN_NO_EVAL_ARGUMENT(base + i, CAR(values));
4102 }
4103 /* macro BUILTIN_NO_EVAL_ARGUMENT does not update
4104 * lisp__data.stack.length, as there is no risk of GC while
4105 * adding the arguments. */
4106 lisp__data.stack.length += i;
4107 }
4108 }
4109 else {
4110 symbols = alist->normals.symbols;
4111 if (eval) {
4112 for (; i < count && CONSP(values); i++, values = CDR(values)) {
4113 NORMAL_ARGUMENT(symbols[i], EVAL(CAR(values)));
4114 }
4115 }
4116 else {
4117 for (; i < count && CONSP(values); i++, values = CDR(values)) {
4118 NORMAL_ARGUMENT(symbols[i], CAR(values));
4119 }
4120 }
4121 }
4122 if (i < count)
4123 LispDestroy("%s: too few arguments", STROBJ(name));
4124
4125 switch (*desc++) {
4126 case 'o':
4127 goto optional_label;
4128 case 'k':
4129 goto key_label;
4130 case 'r':
4131 goto rest_label;
4132 case 'a':
4133 goto aux_label;
4134 default:
4135 goto done_label;
4136 }
4137
4138 /* &OPTIONAL */
4139 optional_label:
4140 i = 0;
4141 count = alist->optionals.num_symbols;
4142 defaults = alist->optionals.defaults;
4143 sforms = alist->optionals.sforms;
4144 if (builtin) {
4145 if (eval) {
4146 for (; i < count && CONSP(values); i++, values = CDR(values))
4147 BUILTIN_ARGUMENT(EVAL(CAR(values)));
4148 for (; i < count; i++)
4149 BUILTIN_ARGUMENT(UNSPEC);
4150 }
4151 else {
4152 for (; i < count && CONSP(values); i++, values = CDR(values))
4153 BUILTIN_ARGUMENT(CAR(values));
4154 for (; i < count; i++)
4155 BUILTIN_ARGUMENT(UNSPEC);
4156 }
4157 }
4158 else {
4159 symbols = alist->optionals.symbols;
4160 if (eval) {
4161 for (; i < count && CONSP(values); i++, values = CDR(values)) {
4162 NORMAL_ARGUMENT(symbols[i], EVAL(CAR(values)));
4163 if (sforms[i]) {
4164 NORMAL_ARGUMENT(sforms[i], T);
4165 }
4166 }
4167 }
4168 else {
4169 for (; i < count && CONSP(values); i++, values = CDR(values)) {
4170 NORMAL_ARGUMENT(symbols[i], CAR(values));
4171 if (sforms[i]) {
4172 NORMAL_ARGUMENT(sforms[i], T);
4173 }
4174 }
4175 }
4176
4177 /* default arguments are evaluated for macros */
4178 for (; i < count; i++) {
4179 if (!CONSTANTP(defaults[i])) {
4180 int head = lisp__data.env.head;
4181 int lex = lisp__data.env.lex;
4182
4183 lisp__data.env.lex = base;
4184 lisp__data.env.head = lisp__data.env.length;
4185 NORMAL_ARGUMENT(symbols[i], EVAL(defaults[i]));
4186 lisp__data.env.head = head;
4187 lisp__data.env.lex = lex;
4188 }
4189 else {
4190 NORMAL_ARGUMENT(symbols[i], defaults[i]);
4191 }
4192 if (sforms[i]) {
4193 NORMAL_ARGUMENT(sforms[i], NIL);
4194 }
4195 }
4196 }
4197 switch (*desc++) {
4198 case 'k':
4199 goto key_label;
4200 case 'r':
4201 goto rest_label;
4202 case 'a':
4203 goto aux_label;
4204 default:
4205 goto done_label;
4206 }
4207
4208 /* &KEY */
4209 key_label:
4210 {
4211 int argc, nused;
4212 LispObj *val, *karg, **keys;
4213
4214 /* Count number of remaining arguments */
4215 for (karg = values, argc = 0; CONSP(karg); karg = CDR(karg), argc++) {
4216 karg = CDR(karg);
4217 if (!CONSP(karg))
4218 LispDestroy("%s: &KEY needs arguments as pairs",
4219 STROBJ(name));
4220 }
4221
4222
4223 /* OPTIMIZATION:
4224 * Builtin functions require that the keyword be in the keyword package.
4225 * User functions don't need the arguments being pushed in the stack
4226 * in the declared order (bytecode expects it...).
4227 * XXX Error checking should be done elsewhere, code may be looping
4228 * and doing error check here may consume too much cpu time.
4229 * XXX Would also be good to already have the arguments specified in
4230 * the correct order.
4231 */
4232
4233
4234 nused = 0;
4235 val = NIL;
4236 count = alist->keys.num_symbols;
4237 symbols = alist->keys.symbols;
4238 defaults = alist->keys.defaults;
4239 sforms = alist->keys.sforms;
4240 if (builtin) {
4241
4242 /* Arguments must be created in the declared order */
4243 i = 0;
4244 if (eval) {
4245 for (; i < count; i++) {
4246 for (karg = values; CONSP(karg); karg = CDDR(karg)) {
4247 /* This is only true if both point to the
4248 * same symbol in the keyword package. */
4249 if (symbols[i] == CAR(karg)) {
4250 if (karg == values)
4251 values = CDDR(values);
4252 ++nused;
4253 BUILTIN_ARGUMENT(EVAL(CADR(karg)));
4254 goto keyword_builtin_eval_used_label;
4255 }
4256 }
4257 BUILTIN_ARGUMENT(UNSPEC);
4258 keyword_builtin_eval_used_label:;
4259 }
4260 }
4261 else {
4262 for (; i < count; i++) {
4263 for (karg = values; CONSP(karg); karg = CDDR(karg)) {
4264 if (symbols[i] == CAR(karg)) {
4265 if (karg == values)
4266 values = CDDR(values);
4267 ++nused;
4268 BUILTIN_ARGUMENT(CADR(karg));
4269 goto keyword_builtin_used_label;
4270 }
4271 }
4272 BUILTIN_ARGUMENT(UNSPEC);
4273 keyword_builtin_used_label:;
4274 }
4275 }
4276
4277 if (argc != nused) {
4278 /* Argument(s) may be incorrectly specified, or specified
4279 * twice (what is not an error). */
4280 for (karg = values; CONSP(karg); karg = CDDR(karg)) {
4281 val = CAR(karg);
4282 if (KEYWORDP(val)) {
4283 for (i = 0; i < count; i++)
4284 if (symbols[i] == val)
4285 break;
4286 }
4287 else
4288 /* Just make the error test true */
4289 i = count;
4290
4291 if (i == count)
4292 goto invalid_keyword_label;
4293 }
4294 }
4295 }
4296
4297 #if 0
4298 else {
4299 /* The base offset of the atom in the stack, to check for
4300 * keywords specified twice. */
4301 LispObj *symbol;
4302 int offset = lisp__data.env.length;
4303
4304 keys = alist->keys.keys;
4305 for (karg = values; CONSP(karg); karg = CDDR(karg)) {
4306 symbol = CAR(karg);
4307 if (SYMBOLP(symbol)) {
4308 /* Must be a keyword, but even if it is a keyword, may
4309 * be a typo, so assume it is correct. If it is not
4310 * in the argument list, it is an error. */
4311 for (i = 0; i < count; i++) {
4312 if (!keys[i] && symbols[i] == symbol) {
4313 LispAtom *atom = symbol->data.atom;
4314
4315 /* Symbol found in the argument list. */
4316 if (atom->offset >= offset &&
4317 atom->offset < offset + nused &&
4318 lisp__data.env.names[atom->offset] ==
4319 atom->string)
4320 /* Specified more than once... */
4321 goto keyword_duplicated_label;
4322 break;
4323 }
4324 }
4325 }
4326 else {
4327 Atom_id id;
4328
4329 if (!QUOTEP(symbol) || !SYMBOLP(val = symbol->data.quote)) {
4330 /* Bad argument. */
4331 val = symbol;
4332 goto invalid_keyword_label;
4333 }
4334
4335 id = ATOMID(val);
4336 for (i = 0; i < count; i++) {
4337 if (keys[i] && ATOMID(keys[i]) == id) {
4338 LispAtom *atom = val->data.atom;
4339
4340 /* Symbol found in the argument list. */
4341 if (atom->offset >= offset &&
4342 atom->offset < offset + nused &&
4343 lisp__data.env.names[atom->offset] ==
4344 atom->string)
4345 /* Specified more than once... */
4346 goto keyword_duplicated_label;
4347 break;
4348 }
4349 }
4350 }
4351 if (i == count) {
4352 /* Argument specification not found. */
4353 val = symbol;
4354 goto invalid_keyword_label;
4355 }
4356 ++nused;
4357 if (eval) {
4358 NORMAL_ARGUMENT(symbols[i], EVAL(CADR(karg)));
4359 }
4360 else {
4361 NORMAL_ARGUMENT(symbols[i], CADR(karg));
4362 }
4363 if (sforms[i]) {
4364 NORMAL_ARGUMENT(sforms[i], T);
4365 }
4366 keyword_duplicated_label:;
4367 }
4368
4369 /* Add variables that were not specified in the function call. */
4370 if (nused < count) {
4371 int j;
4372
4373 for (i = 0; i < count; i++) {
4374 Atom_id id = ATOMID(symbols[i]);
4375
4376 for (j = offset + nused - 1; j >= offset; j--) {
4377 if (lisp__data.env.names[j] == id)
4378 break;
4379 }
4380
4381 if (j < offset) {
4382 /* Argument not specified. Use default value */
4383
4384 /* default arguments are evaluated for macros */
4385 if (!CONSTANTP(defaults[i])) {
4386 int head = lisp__data.env.head;
4387 int lex = lisp__data.env.lex;
4388
4389 lisp__data.env.lex = base;
4390 lisp__data.env.head = lisp__data.env.length;
4391 NORMAL_ARGUMENT(symbols[i], EVAL(defaults[i]));
4392 lisp__data.env.head = head;
4393 lisp__data.env.lex = lex;
4394 }
4395 else {
4396 NORMAL_ARGUMENT(symbols[i], defaults[i]);
4397 }
4398 if (sforms[i]) {
4399 NORMAL_ARGUMENT(sforms[i], NIL);
4400 }
4401 }
4402 }
4403 }
4404 }
4405 #else
4406 else {
4407 int varset;
4408
4409 sforms = alist->keys.sforms;
4410 keys = alist->keys.keys;
4411
4412 /* Add variables */
4413 for (i = 0; i < alist->keys.num_symbols; i++) {
4414 val = defaults[i];
4415 varset = 0;
4416 if (keys[i]) {
4417 Atom_id atom = ATOMID(keys[i]);
4418
4419 /* Special keyword specification, need to compare ATOMID
4420 * and keyword specification must be a quoted object */
4421 for (karg = values; CONSP(karg); karg = CDR(karg)) {
4422 val = CAR(karg);
4423 if (QUOTEP(val) && atom == ATOMID(val->data.quote)) {
4424 val = CADR(karg);
4425 varset = 1;
4426 ++nused;
4427 break;
4428 }
4429 karg = CDR(karg);
4430 }
4431 }
4432
4433 else {
4434 /* Normal keyword specification, can compare object pointers,
4435 * as they point to the same object in the keyword package */
4436 for (karg = values; CONSP(karg); karg = CDR(karg)) {
4437 /* Don't check if argument is a valid keyword or
4438 * special quoted keyword */
4439 if (symbols[i] == CAR(karg)) {
4440 val = CADR(karg);
4441 varset = 1;
4442 ++nused;
4443 break;
4444 }
4445 karg = CDR(karg);
4446 }
4447 }
4448
4449 /* Add the variable to environment */
4450 if (varset) {
4451 NORMAL_ARGUMENT(symbols[i], eval ? EVAL(val) : val);
4452 if (sforms[i]) {
4453 NORMAL_ARGUMENT(sforms[i], T);
4454 }
4455 }
4456 else {
4457 /* default arguments are evaluated for macros */
4458 if (!CONSTANTP(val)) {
4459 int head = lisp__data.env.head;
4460 int lex = lisp__data.env.lex;
4461
4462 lisp__data.env.lex = base;
4463 lisp__data.env.head = lisp__data.env.length;
4464 NORMAL_ARGUMENT(symbols[i], EVAL(val));
4465 lisp__data.env.head = head;
4466 lisp__data.env.lex = lex;
4467 }
4468 else {
4469 NORMAL_ARGUMENT(symbols[i], val);
4470 }
4471 if (sforms[i]) {
4472 NORMAL_ARGUMENT(sforms[i], NIL);
4473 }
4474 }
4475 }
4476
4477 if (argc != nused) {
4478 /* Argument(s) may be incorrectly specified, or specified
4479 * twice (what is not an error). */
4480 for (karg = values; CONSP(karg); karg = CDDR(karg)) {
4481 val = CAR(karg);
4482 if (KEYWORDP(val)) {
4483 for (i = 0; i < count; i++)
4484 if (symbols[i] == val)
4485 break;
4486 }
4487 else if (QUOTEP(val) && SYMBOLP(val->data.quote)) {
4488 Atom_id atom = ATOMID(val->data.quote);
4489
4490 for (i = 0; i < count; i++)
4491 if (ATOMID(keys[i]) == atom)
4492 break;
4493 }
4494 else
4495 /* Just make the error test true */
4496 i = count;
4497
4498 if (i == count)
4499 goto invalid_keyword_label;
4500 }
4501 }
4502 }
4503 #endif
4504 goto check_aux_label;
4505
4506 invalid_keyword_label:
4507 {
4508 /* If not in argument specification list... */
4509 char function_name[36];
4510
4511 strcpy(function_name, STROBJ(name));
4512 LispDestroy("%s: %s is an invalid keyword",
4513 function_name, STROBJ(val));
4514 }
4515 }
4516
4517 check_aux_label:
4518 if (*desc == 'a') {
4519 /* &KEY uses all remaining arguments */
4520 values = NIL;
4521 goto aux_label;
4522 }
4523 goto finished_label;
4524
4525 /* &REST */
4526 rest_label:
4527 if (!CONSP(values)) {
4528 if (builtin) {
4529 BUILTIN_ARGUMENT(values);
4530 }
4531 else {
4532 NORMAL_ARGUMENT(alist->rest, values);
4533 }
4534 values = NIL;
4535 }
4536 /* always allocate a new list, don't know if it will be retained */
4537 else if (eval) {
4538 LispObj *cons;
4539
4540 cons = CONS(EVAL(CAR(values)), NIL);
4541 if (builtin) {
4542 BUILTIN_ARGUMENT(cons);
4543 }
4544 else {
4545 NORMAL_ARGUMENT(alist->rest, cons);
4546 }
4547 values = CDR(values);
4548 for (; CONSP(values); values = CDR(values)) {
4549 RPLACD(cons, CONS(EVAL(CAR(values)), NIL));
4550 cons = CDR(cons);
4551 }
4552 }
4553 else {
4554 LispObj *cons;
4555
4556 cons = CONS(CAR(values), NIL);
4557 if (builtin) {
4558 BUILTIN_ARGUMENT(cons);
4559 }
4560 else {
4561 NORMAL_ARGUMENT(alist->rest, cons);
4562 }
4563 values = CDR(values);
4564 for (; CONSP(values); values = CDR(values)) {
4565 RPLACD(cons, CONS(CAR(values), NIL));
4566 cons = CDR(cons);
4567 }
4568 }
4569 if (*desc != 'a')
4570 goto finished_label;
4571
4572 /* &AUX */
4573 aux_label:
4574 i = 0;
4575 count = alist->auxs.num_symbols;
4576 defaults = alist->auxs.initials;
4577 symbols = alist->auxs.symbols;
4578 {
4579 int lex = lisp__data.env.lex;
4580
4581 lisp__data.env.lex = base;
4582 lisp__data.env.head = lisp__data.env.length;
4583 for (; i < count; i++) {
4584 NORMAL_ARGUMENT(symbols[i], EVAL(defaults[i]));
4585 ++lisp__data.env.head;
4586 }
4587 lisp__data.env.lex = lex;
4588 }
4589
4590 done_label:
4591 if (CONSP(values))
4592 LispDestroy("%s: too many arguments", STROBJ(name));
4593
4594 finished_label:
4595 if (builtin)
4596 lisp__data.stack.base = base;
4597 else {
4598 lisp__data.env.head = lisp__data.env.length;
4599 }
4600 #undef BULTIN_ARGUMENT
4601 #undef NORMAL_ARGUMENT
4602 #undef BUILTIN_NO_EVAL_ARGUMENT
4603
4604 return (base);
4605 }
4606
4607 LispObj *
LispFuncall(LispObj * function,LispObj * arguments,int eval)4608 LispFuncall(LispObj *function, LispObj *arguments, int eval)
4609 {
4610 LispAtom *atom;
4611 LispArgList *alist;
4612 LispBuiltin *builtin;
4613 LispObj *lambda, *result;
4614 int macro, base;
4615
4616 #ifdef DEBUGGER
4617 if (lisp__data.debugging)
4618 LispDebugger(LispDebugCallBegin, function, arguments);
4619 #endif
4620
4621 switch (OBJECT_TYPE(function)) {
4622 case LispFunction_t:
4623 function = function->data.atom->object;
4624 case LispAtom_t:
4625 atom = function->data.atom;
4626 if (atom->a_builtin) {
4627 builtin = atom->property->fun.builtin;
4628
4629 if (eval)
4630 eval = builtin->type != LispMacro;
4631 base = LispMakeEnvironment(atom->property->alist,
4632 arguments, function, eval, 1);
4633 if (builtin->multiple_values) {
4634 RETURN_COUNT = 0;
4635 result = builtin->function(builtin);
4636 }
4637 else {
4638 result = builtin->function(builtin);
4639 RETURN_COUNT = 0;
4640 }
4641 lisp__data.stack.base = lisp__data.stack.length = base;
4642 }
4643 else if (atom->a_compiled) {
4644 int lex = lisp__data.env.lex;
4645 lambda = atom->property->fun.function;
4646 alist = atom->property->alist;
4647
4648 base = LispMakeEnvironment(alist, arguments, function, eval, 0);
4649 lisp__data.env.lex = base;
4650 result = LispExecuteBytecode(lambda);
4651 lisp__data.env.lex = lex;
4652 lisp__data.env.head = lisp__data.env.length = base;
4653 }
4654 else if (atom->a_function) {
4655 lambda = atom->property->fun.function;
4656 macro = lambda->funtype == LispMacro;
4657 alist = atom->property->alist;
4658
4659 lambda = lambda->data.lambda.code;
4660 if (eval)
4661 eval = !macro;
4662 base = LispMakeEnvironment(alist, arguments, function, eval, 0);
4663 result = LispRunFunMac(function, lambda, macro, base);
4664 }
4665 else if (atom->a_defstruct &&
4666 atom->property->structure.function != STRUCT_NAME) {
4667 LispObj cons;
4668
4669 if (atom->property->structure.function == STRUCT_CONSTRUCTOR)
4670 atom = Omake_struct->data.atom;
4671 else if (atom->property->structure.function == STRUCT_CHECK)
4672 atom = Ostruct_type->data.atom;
4673 else
4674 atom = Ostruct_access->data.atom;
4675 builtin = atom->property->fun.builtin;
4676
4677 cons.type = LispCons_t;
4678 cons.data.cons.cdr = arguments;
4679 if (eval) {
4680 LispObj quote;
4681
4682 quote.type = LispQuote_t;
4683 quote.data.quote = function;
4684 cons.data.cons.car = "e;
4685 base = LispMakeEnvironment(atom->property->alist,
4686 &cons, function, 1, 1);
4687 }
4688 else {
4689 cons.data.cons.car = function;
4690 base = LispMakeEnvironment(atom->property->alist,
4691 &cons, function, 0, 1);
4692 }
4693 result = builtin->function(builtin);
4694 RETURN_COUNT = 0;
4695 lisp__data.stack.length = base;
4696 }
4697 else {
4698 LispDestroy("EVAL: the function %s is not defined",
4699 STROBJ(function));
4700 /*NOTREACHED*/
4701 result = NIL;
4702 }
4703 break;
4704 case LispLambda_t:
4705 lambda = function->data.lambda.code;
4706 alist = (LispArgList*)function->data.lambda.name->data.opaque.data;
4707 base = LispMakeEnvironment(alist, arguments, function, eval, 0);
4708 result = LispRunFunMac(function, lambda, 0, base);
4709 break;
4710 case LispCons_t:
4711 if (CAR(function) == Olambda) {
4712 function = EVAL(function);
4713 if (LAMBDAP(function)) {
4714 GC_ENTER();
4715
4716 GC_PROTECT(function);
4717 lambda = function->data.lambda.code;
4718 alist = (LispArgList*)function->data.lambda.name->data.opaque.data;
4719 base = LispMakeEnvironment(alist, arguments, NIL, eval, 0);
4720 result = LispRunFunMac(NIL, lambda, 0, base);
4721 GC_LEAVE();
4722 break;
4723 }
4724 }
4725 default:
4726 LispDestroy("EVAL: %s is invalid as a function",
4727 STROBJ(function));
4728 /*NOTREACHED*/
4729 result = NIL;
4730 break;
4731 }
4732
4733 #ifdef DEBUGGER
4734 if (lisp__data.debugging)
4735 LispDebugger(LispDebugCallEnd, function, result);
4736 #endif
4737
4738 return (result);
4739 }
4740
4741 LispObj *
LispEval(LispObj * object)4742 LispEval(LispObj *object)
4743 {
4744 LispObj *result;
4745
4746 switch (OBJECT_TYPE(object)) {
4747 case LispAtom_t:
4748 if ((result = LispDoGetVar(object)) == NULL)
4749 LispDestroy("EVAL: the variable %s is unbound", STROBJ(object));
4750 break;
4751 case LispCons_t:
4752 result = LispFuncall(CAR(object), CDR(object), 1);
4753 break;
4754 case LispQuote_t:
4755 result = object->data.quote;
4756 break;
4757 case LispFunctionQuote_t:
4758 result = object->data.quote;
4759 if (SYMBOLP(result))
4760 result = LispSymbolFunction(result);
4761 else if (CONSP(result) && CAR(result) == Olambda)
4762 result = EVAL(result);
4763 else
4764 LispDestroy("FUNCTION: %s is not a function", STROBJ(result));
4765 break;
4766 case LispBackquote_t:
4767 result = LispEvalBackquote(object->data.quote, 1);
4768 break;
4769 case LispComma_t:
4770 LispDestroy("EVAL: comma outside of backquote");
4771 default:
4772 result = object;
4773 break;
4774 }
4775
4776 return (result);
4777 }
4778
4779 LispObj *
LispApply1(LispObj * function,LispObj * argument)4780 LispApply1(LispObj *function, LispObj *argument)
4781 {
4782 LispObj arguments;
4783
4784 arguments.type = LispCons_t;
4785 arguments.data.cons.car = argument;
4786 arguments.data.cons.cdr = NIL;
4787
4788 return (LispFuncall(function, &arguments, 0));
4789 }
4790
4791 LispObj *
LispApply2(LispObj * function,LispObj * argument1,LispObj * argument2)4792 LispApply2(LispObj *function, LispObj *argument1, LispObj *argument2)
4793 {
4794 LispObj arguments, cdr;
4795
4796 arguments.type = cdr.type = LispCons_t;
4797 arguments.data.cons.car = argument1;
4798 arguments.data.cons.cdr = &cdr;
4799 cdr.data.cons.car = argument2;
4800 cdr.data.cons.cdr = NIL;
4801
4802 return (LispFuncall(function, &arguments, 0));
4803 }
4804
4805 LispObj *
LispApply3(LispObj * function,LispObj * arg1,LispObj * arg2,LispObj * arg3)4806 LispApply3(LispObj *function, LispObj *arg1, LispObj *arg2, LispObj *arg3)
4807 {
4808 LispObj arguments, car, cdr;
4809
4810 arguments.type = car.type = cdr.type = LispCons_t;
4811 arguments.data.cons.car = arg1;
4812 arguments.data.cons.cdr = &car;
4813 car.data.cons.car = arg2;
4814 car.data.cons.cdr = &cdr;
4815 cdr.data.cons.car = arg3;
4816 cdr.data.cons.cdr = NIL;
4817
4818 return (LispFuncall(function, &arguments, 0));
4819 }
4820
4821 static LispObj *
LispRunFunMac(LispObj * name,LispObj * code,int macro,int base)4822 LispRunFunMac(LispObj *name, LispObj *code, int macro, int base)
4823 {
4824 LispObj *result = NIL;
4825
4826 if (!macro) {
4827 int lex = lisp__data.env.lex;
4828 int did_jump = 1;
4829 LispBlock *block;
4830
4831 block = LispBeginBlock(name, LispBlockClosure);
4832 lisp__data.env.lex = base;
4833 if (setjmp(block->jmp) == 0) {
4834 for (; CONSP(code); code = CDR(code))
4835 result = EVAL(CAR(code));
4836 did_jump = 0;
4837 }
4838 LispEndBlock(block);
4839 if (did_jump)
4840 result = lisp__data.block.block_ret;
4841 lisp__data.env.lex = lex;
4842 lisp__data.env.head = lisp__data.env.length = base;
4843 }
4844 else {
4845 GC_ENTER();
4846
4847 for (; CONSP(code); code = CDR(code))
4848 result = EVAL(CAR(code));
4849 /* FIXME this does not work if macro has &aux variables,
4850 * but there are several other missing features, like
4851 * destructuring and more lambda list keywords still missing.
4852 * TODO later.
4853 */
4854 lisp__data.env.head = lisp__data.env.length = base;
4855
4856 GC_PROTECT(result);
4857 result = EVAL(result);
4858 GC_LEAVE();
4859 }
4860
4861 return (result);
4862 }
4863
4864 LispObj *
LispRunSetf(LispArgList * alist,LispObj * setf,LispObj * place,LispObj * value)4865 LispRunSetf(LispArgList *alist, LispObj *setf, LispObj *place, LispObj *value)
4866 {
4867 GC_ENTER();
4868 LispObj *store, *code, *expression, *result, quote;
4869 int base;
4870
4871 code = setf->data.lambda.code;
4872 store = setf->data.lambda.data;
4873
4874 quote.type = LispQuote_t;
4875 quote.data.quote = value;
4876 LispDoAddVar(CAR(store), "e);
4877 ++lisp__data.env.head;
4878 base = LispMakeEnvironment(alist, place, Oexpand_setf_method, 0, 0);
4879
4880 /* build expansion macro */
4881 expression = NIL;
4882 for (; CONSP(code); code = CDR(code))
4883 expression = EVAL(CAR(code));
4884
4885 /* Minus 1 to pop the added variable */
4886 lisp__data.env.head = lisp__data.env.length = base - 1;
4887
4888 /* protect expansion, and executes it */
4889 GC_PROTECT(expression);
4890 result = EVAL(expression);
4891 GC_LEAVE();
4892
4893 return (result);
4894 }
4895
4896 LispObj *
LispRunSetfMacro(LispAtom * atom,LispObj * arguments,LispObj * value)4897 LispRunSetfMacro(LispAtom *atom, LispObj *arguments, LispObj *value)
4898 {
4899 int base;
4900 GC_ENTER();
4901 LispObj *place, *body, *result, quote;
4902
4903 place = NIL;
4904 base = LispMakeEnvironment(atom->property->alist,
4905 arguments, atom->object, 0, 0);
4906 body = atom->property->fun.function->data.lambda.code;
4907
4908 /* expand macro body */
4909 for (; CONSP(body); body = CDR(body))
4910 place = EVAL(CAR(body));
4911
4912 /* protect expansion */
4913 GC_PROTECT(place);
4914
4915 /* restore environment */
4916 lisp__data.env.head = lisp__data.env.length = base;
4917
4918 /* value is already evaluated */
4919 quote.type = LispQuote_t;
4920 quote.data.quote = value;
4921
4922 /* call setf again */
4923 result = APPLY2(Osetf, place, "e);
4924
4925 GC_LEAVE();
4926
4927 return (result);
4928 }
4929
4930 char *
LispStrObj(LispObj * object)4931 LispStrObj(LispObj *object)
4932 {
4933 static int first = 1;
4934 static char buffer[34];
4935 static LispObj stream;
4936 static LispString string;
4937
4938 if (first) {
4939 stream.type = LispStream_t;
4940 stream.data.stream.source.string = &string;
4941 stream.data.stream.pathname = NIL;
4942 stream.data.stream.type = LispStreamString;
4943 stream.data.stream.readable = 0;
4944 stream.data.stream.writable = 1;
4945
4946 string.string = buffer;
4947 string.fixed = 1;
4948 string.space = sizeof(buffer) - 1;
4949 first = 0;
4950 }
4951
4952 string.length = string.output = 0;
4953
4954 LispWriteObject(&stream, object);
4955
4956 /* make sure string is nul terminated */
4957 string.string[string.length] = '\0';
4958 if (string.length >= 32) {
4959 if (buffer[0] == '(')
4960 strcpy(buffer + 27, "...)");
4961 else
4962 strcpy(buffer + 28, "...");
4963 }
4964
4965 return (buffer);
4966 }
4967
4968 void
LispPrint(LispObj * object,LispObj * stream,int newline)4969 LispPrint(LispObj *object, LispObj *stream, int newline)
4970 {
4971 if (stream != NIL && !STREAMP(stream)) {
4972 LispDestroy("PRINT: %s is not a stream", STROBJ(stream));
4973 }
4974 if (newline && LispGetColumn(stream))
4975 LispWriteChar(stream, '\n');
4976 LispWriteObject(stream, object);
4977 if (stream == NIL || (stream->data.stream.type == LispStreamStandard &&
4978 stream->data.stream.source.file == Stdout))
4979 LispFflush(Stdout);
4980 }
4981
4982 void
LispUpdateResults(LispObj * cod,LispObj * res)4983 LispUpdateResults(LispObj *cod, LispObj *res)
4984 {
4985 LispSetVar(RUN[2], LispGetVar(RUN[1]));
4986 LispSetVar(RUN[1], LispGetVar(RUN[0]));
4987 LispSetVar(RUN[0], cod);
4988
4989 LispSetVar(RES[2], LispGetVar(RES[1]));
4990 LispSetVar(RES[1], LispGetVar(RES[0]));
4991 LispSetVar(RES[0], res);
4992 }
4993
4994 void
LispSignalHandler(int signum)4995 LispSignalHandler(int signum)
4996 {
4997 LispSignal(signum);
4998 }
4999
5000 void
LispSignal(int signum)5001 LispSignal(int signum)
5002 {
5003 const char *errstr;
5004 char buffer[32];
5005
5006 if (lisp__disable_int) {
5007 lisp__interrupted = signum;
5008 return;
5009 }
5010 switch (signum) {
5011 case SIGINT:
5012 errstr = "interrupted";
5013 break;
5014 case SIGFPE:
5015 errstr = "floating point exception";
5016 break;
5017 default:
5018 sprintf(buffer, "signal %d received", signum);
5019 errstr = buffer;
5020 break;
5021 }
5022 LispDestroy("%s", errstr);
5023 }
5024
5025 void
LispDisableInterrupts(void)5026 LispDisableInterrupts(void)
5027 {
5028 ++lisp__disable_int;
5029 }
5030
5031 void
LispEnableInterrupts(void)5032 LispEnableInterrupts(void)
5033 {
5034 --lisp__disable_int;
5035 if (lisp__disable_int <= 0 && lisp__interrupted)
5036 LispSignal(lisp__interrupted);
5037 }
5038
5039 void
LispMachine(void)5040 LispMachine(void)
5041 {
5042 LispObj *cod, *obj;
5043
5044 lisp__data.sigint = signal(SIGINT, LispSignalHandler);
5045 lisp__data.sigfpe = signal(SIGFPE, LispSignalHandler);
5046
5047 /*CONSTCOND*/
5048 while (1) {
5049 if (sigsetjmp(lisp__data.jmp, 1) == 0) {
5050 lisp__data.running = 1;
5051 if (lisp__data.interactive && lisp__data.prompt) {
5052 LispFputs(Stdout, lisp__data.prompt);
5053 LispFflush(Stdout);
5054 }
5055 if ((cod = LispRead()) != NULL) {
5056 obj = EVAL(cod);
5057 if (lisp__data.interactive) {
5058 if (RETURN_COUNT >= 0)
5059 LispPrint(obj, NIL, 1);
5060 if (RETURN_COUNT > 0) {
5061 int i;
5062
5063 for (i = 0; i < RETURN_COUNT; i++)
5064 LispPrint(RETURN(i), NIL, 1);
5065 }
5066 LispUpdateResults(cod, obj);
5067 if (LispGetColumn(NIL))
5068 LispWriteChar(NIL, '\n');
5069 }
5070 }
5071 LispTopLevel();
5072 }
5073 if (lisp__data.eof)
5074 break;
5075 }
5076
5077 signal(SIGINT, lisp__data.sigint);
5078 signal(SIGFPE, lisp__data.sigfpe);
5079
5080 lisp__data.running = 0;
5081 }
5082
5083 void *
LispExecute(char * str)5084 LispExecute(char *str)
5085 {
5086 static LispObj stream;
5087 static LispString string;
5088 static int first = 1;
5089
5090 int running = lisp__data.running;
5091 LispObj *result, *cod, *obj, **presult = &result;
5092
5093 if (str == NULL || *str == '\0')
5094 return (NIL);
5095
5096 *presult = NIL;
5097
5098 if (first) {
5099 stream.type = LispStream_t;
5100 stream.data.stream.source.string = &string;
5101 stream.data.stream.pathname = NIL;
5102 stream.data.stream.type = LispStreamString;
5103 stream.data.stream.readable = 1;
5104 stream.data.stream.writable = 0;
5105 string.output = 0;
5106 first = 0;
5107 }
5108 string.string = str;
5109 string.length = strlen(str);
5110 string.input = 0;
5111
5112 LispPushInput(&stream);
5113 if (!running) {
5114 lisp__data.running = 1;
5115 if (sigsetjmp(lisp__data.jmp, 1) != 0)
5116 return (NULL);
5117 }
5118
5119 cod = COD;
5120 /*CONSTCOND*/
5121 while (1) {
5122 if ((obj = LispRead()) != NULL) {
5123 result = EVAL(obj);
5124 COD = cod;
5125 }
5126 if (lisp__data.eof)
5127 break;
5128 }
5129 LispPopInput(&stream);
5130
5131 lisp__data.running = running;
5132
5133 return (result);
5134 }
5135
5136 void
LispBegin(void)5137 LispBegin(void)
5138 {
5139 int i;
5140 LispAtom *atom;
5141 char results[4];
5142 LispObj *object, *path, *ext;
5143
5144 pagesize = LispGetPageSize();
5145 segsize = pagesize / sizeof(LispObj);
5146
5147 lisp__data.strings = hash_new(STRTBLSZ, NULL);
5148 lisp__data.opqs = hash_new(STRTBLSZ, NULL);
5149
5150 /* Initialize memory management */
5151 lisp__data.mem.mem = (void**)calloc(lisp__data.mem.space = 16,
5152 sizeof(void*));
5153 lisp__data.mem.index = lisp__data.mem.level = 0;
5154
5155 /* Allow LispGetVar to check ATOMID() of unbound symbols */
5156 UNBOUND->data.atom = (LispAtom*)LispCalloc(1, sizeof(LispAtom));
5157 LispMused(UNBOUND->data.atom);
5158 noproperty.value = UNBOUND;
5159
5160 if (Stdin == NULL)
5161 Stdin = LispFdopen(0, FILE_READ);
5162 if (Stdout == NULL)
5163 Stdout = LispFdopen(1, FILE_WRITE | FILE_BUFFERED);
5164 if (Stderr == NULL)
5165 Stderr = LispFdopen(2, FILE_WRITE);
5166
5167 /* minimum number of free cells after GC
5168 * if sizeof(LispObj) == 16, than a minfree of 1024 would try to keep
5169 * at least 16Kb of free cells.
5170 */
5171 minfree = 1024;
5172
5173 MOD = COD = PRO = NIL;
5174 #ifdef DEBUGGER
5175 DBG = BRK = NIL;
5176 #endif
5177
5178 /* allocate initial object cells */
5179 LispAllocSeg(&objseg, minfree);
5180 LispAllocSeg(&atomseg, pagesize);
5181 lisp__data.gc.average = segsize;
5182
5183 /* Don't allow gc in initialization */
5184 GCDisable();
5185
5186 /* Initialize package system, the current package is LISP. Order of
5187 * initialization is very important here */
5188 lisp__data.lisp = LispNewPackage(STRING("LISP"),
5189 CONS(STRING("COMMON-LISP"), NIL));
5190
5191 /* Make LISP package the current one */
5192 lisp__data.pack = lisp__data.savepack =
5193 lisp__data.lisp->data.package.package;
5194
5195 /* Allocate space in LISP package */
5196 LispMoreGlobals(lisp__data.pack);
5197
5198 /* Allocate space for multiple value return values */
5199 lisp__data.returns.values = malloc(MULTIPLE_VALUES_LIMIT *
5200 (sizeof(LispObj*)));
5201
5202 /* Create the first atom, do it "by hand" because macro "PACKAGE"
5203 * cannot yet be used. */
5204 atom = LispGetPermAtom("*PACKAGE*");
5205 lisp__data.package = atomseg.freeobj;
5206 atomseg.freeobj = CDR(atomseg.freeobj);
5207 --atomseg.nfree;
5208 lisp__data.package->type = LispAtom_t;
5209 lisp__data.package->data.atom = atom;
5210 atom->object = lisp__data.package;
5211 atom->package = lisp__data.lisp;
5212
5213 /* Set package list, to be used by (gc) and (list-all-packages) */
5214 PACK = CONS(lisp__data.lisp, NIL);
5215
5216 /* Make *PACKAGE* a special variable */
5217 LispProclaimSpecial(lisp__data.package, lisp__data.lisp, NIL);
5218
5219 /* Value of macro "PACKAGE" is now properly available */
5220
5221 /* Changing *PACKAGE* is like calling (in-package) */
5222 lisp__data.package->data.atom->watch = 1;
5223
5224 /* And available to other packages */
5225 LispExportSymbol(lisp__data.package);
5226
5227 /* Initialize stacks */
5228 LispMoreEnvironment();
5229 LispMoreStack();
5230
5231 /* Create the KEYWORD package */
5232 Skeyword = GETATOMID("KEYWORD");
5233 object = LispNewPackage(STRING(Skeyword->value),
5234 CONS(STRING(""), NIL));
5235
5236 /* Update list of packages */
5237 PACK = CONS(object, PACK);
5238
5239 /* Allow easy access to the keyword package */
5240 lisp__data.keyword = object;
5241 lisp__data.key = object->data.package.package;
5242
5243 /* Initialize some static important symbols */
5244 Olambda = STATIC_ATOM("LAMBDA");
5245 LispExportSymbol(Olambda);
5246 Okey = STATIC_ATOM("&KEY");
5247 LispExportSymbol(Okey);
5248 Orest = STATIC_ATOM("&REST");
5249 LispExportSymbol(Orest);
5250 Ooptional = STATIC_ATOM("&OPTIONAL");
5251 LispExportSymbol(Ooptional);
5252 Oaux = STATIC_ATOM("&AUX");
5253 LispExportSymbol(Oaux);
5254 Kunspecific = KEYWORD("UNSPECIFIC");
5255 Oformat = STATIC_ATOM("FORMAT");
5256 Oexpand_setf_method = STATIC_ATOM("EXPAND-SETF-METHOD");
5257
5258 Omake_struct = STATIC_ATOM("MAKE-STRUCT");
5259 Ostruct_access = STATIC_ATOM("STRUCT-ACCESS");
5260 Ostruct_store = STATIC_ATOM("STRUCT-STORE");
5261 Ostruct_type = STATIC_ATOM("STRUCT-TYPE");
5262 Smake_struct = ATOMID(Omake_struct);
5263 Sstruct_access = ATOMID(Ostruct_access);
5264 Sstruct_store = ATOMID(Ostruct_store);
5265 Sstruct_type = ATOMID(Ostruct_type);
5266
5267 /* Initialize some static atom ids */
5268 Snil = GETATOMID("NIL");
5269 St = GETATOMID("T");
5270 Saux = ATOMID(Oaux);
5271 Skey = ATOMID(Okey);
5272 Soptional = ATOMID(Ooptional);
5273 Srest = ATOMID(Orest);
5274 Sand = GETATOMID("AND");
5275 Sor = GETATOMID("OR");
5276 Snot = GETATOMID("NOT");
5277 Satom = GETATOMID("ATOM");
5278 Ssymbol = GETATOMID("SYMBOL");
5279 Sinteger = GETATOMID("INTEGER");
5280 Scharacter = GETATOMID("CHARACTER");
5281 Sstring = GETATOMID("STRING");
5282 Slist = GETATOMID("LIST");
5283 Scons = GETATOMID("CONS");
5284 Svector = GETATOMID("VECTOR");
5285 Sarray = GETATOMID("ARRAY");
5286 Sstruct = GETATOMID("STRUCT");
5287 Sfunction = GETATOMID("FUNCTION");
5288 Spathname = GETATOMID("PATHNAME");
5289 Srational = GETATOMID("RATIONAL");
5290 Sfloat = GETATOMID("FLOAT");
5291 Scomplex = GETATOMID("COMPLEX");
5292 Sopaque = GETATOMID("OPAQUE");
5293 Sdefault = GETATOMID("DEFAULT");
5294
5295 LispArgList_t = LispRegisterOpaqueType("LispArgList*");
5296
5297 lisp__data.unget = malloc(sizeof(LispUngetInfo*));
5298 lisp__data.unget[0] = calloc(1, sizeof(LispUngetInfo));
5299 lisp__data.nunget = 1;
5300
5301 lisp__data.standard_input = ATOM2("*STANDARD-INPUT*");
5302 SINPUT = STANDARDSTREAM(Stdin, lisp__data.standard_input, STREAM_READ);
5303 lisp__data.interactive = 1;
5304 LispProclaimSpecial(lisp__data.standard_input,
5305 lisp__data.input_list = SINPUT, NIL);
5306 LispExportSymbol(lisp__data.standard_input);
5307
5308 lisp__data.standard_output = ATOM2("*STANDARD-OUTPUT*");
5309 SOUTPUT = STANDARDSTREAM(Stdout, lisp__data.standard_output, STREAM_WRITE);
5310 LispProclaimSpecial(lisp__data.standard_output,
5311 lisp__data.output_list = SOUTPUT, NIL);
5312 LispExportSymbol(lisp__data.standard_output);
5313
5314 object = ATOM2("*STANDARD-ERROR*");
5315 lisp__data.error_stream = STANDARDSTREAM(Stderr, object, STREAM_WRITE);
5316 LispProclaimSpecial(object, lisp__data.error_stream, NIL);
5317 LispExportSymbol(object);
5318
5319 lisp__data.modules = ATOM2("*MODULES*");
5320 LispProclaimSpecial(lisp__data.modules, MOD, NIL);
5321 LispExportSymbol(lisp__data.modules);
5322
5323 object = CONS(KEYWORD("UNIX"), CONS(KEYWORD("XEDIT"), NIL));
5324 lisp__data.features = ATOM2("*FEATURES*");
5325 LispProclaimSpecial(lisp__data.features, object, NIL);
5326 LispExportSymbol(lisp__data.features);
5327
5328 object = ATOM2("MULTIPLE-VALUES-LIMIT");
5329 LispDefconstant(object, FIXNUM(MULTIPLE_VALUES_LIMIT + 1), NIL);
5330 LispExportSymbol(object);
5331
5332 /* Reenable gc */
5333 GCEnable();
5334
5335 LispBytecodeInit();
5336 LispPackageInit();
5337 LispCoreInit();
5338 LispMathInit();
5339 LispPathnameInit();
5340 LispStreamInit();
5341 LispRegexInit();
5342 LispWriteInit();
5343
5344 lisp__data.prompt = isatty(0) ? "> " : NULL;
5345
5346 lisp__data.errexit = !lisp__data.interactive;
5347
5348 if (lisp__data.interactive) {
5349 /* add +, ++, +++, *, **, and *** */
5350 for (i = 0; i < 3; i++) {
5351 results[i] = '+';
5352 results[i + 1] = '\0';
5353 RUN[i] = ATOM(results);
5354 LispSetVar(RUN[i], NIL);
5355 LispExportSymbol(RUN[i]);
5356 }
5357 for (i = 0; i < 3; i++) {
5358 results[i] = '*';
5359 results[i + 1] = '\0';
5360 RES[i] = ATOM(results);
5361 LispSetVar(RES[i], NIL);
5362 LispExportSymbol(RES[i]);
5363 }
5364 }
5365 else
5366 RUN[0] = RUN[1] = RUN[2] = RES[0] = RES[1] = RES[2] = NIL;
5367
5368 /* Add LISP builtin functions */
5369 for (i = 0; i < sizeof(lispbuiltins) / sizeof(lispbuiltins[0]); i++)
5370 LispAddBuiltinFunction(&lispbuiltins[i]);
5371
5372 EXECUTE("(require \"lisp\")");
5373
5374 object = ATOM2("*DEFAULT-PATHNAME-DEFAULTS*");
5375 #ifdef LISPDIR
5376 {
5377 int length;
5378 const char *pathname = LISPDIR;
5379
5380 length = strlen(pathname);
5381 if (length && pathname[length - 1] != '/') {
5382 char *fixed_pathname = LispMalloc(length + 2);
5383
5384 strcpy(fixed_pathname, LISPDIR);
5385 strcpy(fixed_pathname + length, "/");
5386 path = LSTRING2(fixed_pathname, length + 1);
5387 }
5388 else
5389 path = LSTRING(pathname, length);
5390 }
5391 #else
5392 path = STRING("");
5393 #endif
5394 GCDisable();
5395 LispProclaimSpecial(object, APPLY1(Oparse_namestring, path), NIL);
5396 LispExportSymbol(object);
5397 GCEnable();
5398
5399 /* Create and make EXT the current package */
5400 PACKAGE = ext = LispNewPackage(STRING("EXT"), NIL);
5401 lisp__data.pack = lisp__data.savepack = PACKAGE->data.package.package;
5402
5403 /* Update list of packages */
5404 PACK = CONS(ext, PACK);
5405
5406 /* Import LISP external symbols in EXT package */
5407 LispUsePackage(lisp__data.lisp);
5408
5409 /* Add EXT non standard builtin functions */
5410 for (i = 0; i < sizeof(extbuiltins) / sizeof(extbuiltins[0]); i++)
5411 LispAddBuiltinFunction(&extbuiltins[i]);
5412
5413 /* Create and make USER the current package */
5414 GCDisable();
5415 PACKAGE = LispNewPackage(STRING("USER"),
5416 CONS(STRING("COMMON-LISP-USER"), NIL));
5417 GCEnable();
5418 lisp__data.pack = lisp__data.savepack = PACKAGE->data.package.package;
5419
5420 /* Update list of packages */
5421 PACK = CONS(PACKAGE, PACK);
5422
5423 /* USER package inherits all LISP external symbols */
5424 LispUsePackage(lisp__data.lisp);
5425 /* And all EXT external symbols */
5426 LispUsePackage(ext);
5427
5428 LispTopLevel();
5429 }
5430
5431 void
LispEnd(void)5432 LispEnd(void)
5433 {
5434 /* XXX needs to free all used memory, not just close file descriptors */
5435 }
5436
5437 void
LispSetPrompt(const char * prompt)5438 LispSetPrompt(const char *prompt)
5439 {
5440 lisp__data.prompt = prompt;
5441 }
5442
5443 void
LispSetInteractive(int interactive)5444 LispSetInteractive(int interactive)
5445 {
5446 lisp__data.interactive = !!interactive;
5447 }
5448
5449 void
LispSetExitOnError(int errexit)5450 LispSetExitOnError(int errexit)
5451 {
5452 lisp__data.errexit = !!errexit;
5453 }
5454
5455 void
LispDebug(int enable)5456 LispDebug(int enable)
5457 {
5458 lisp__data.debugging = !!enable;
5459
5460 #ifdef DEBUGGER
5461 /* assumes we are at the toplevel */
5462 DBG = BRK = NIL;
5463 lisp__data.debug_level = -1;
5464 lisp__data.debug_step = 0;
5465 #endif
5466 }
5467