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