lisp.c revision f14f4646
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 85typedef struct { 86 LispObj **objects; 87 LispObj *freeobj; 88 int nsegs; 89 int nobjs; 90 int nfree; 91} LispObjSeg; 92 93/* 94 * Prototypes 95 */ 96static void Lisp__GC(LispObj*, LispObj*); 97static LispObj *Lisp__New(LispObj*, LispObj*); 98 99/* run a user function, to be called only by LispEval */ 100static LispObj *LispRunFunMac(LispObj*, LispObj*, int, int); 101 102/* expands and executes a setf method, to be called only by Lisp_Setf */ 103LispObj *LispRunSetf(LispArgList*, LispObj*, LispObj*, LispObj*); 104LispObj *LispRunSetfMacro(LispAtom*, LispObj*, LispObj*); 105 106/* increases storage size for environment */ 107void LispMoreEnvironment(void); 108 109/* increases storage size for stack of builtin arguments */ 110void LispMoreStack(void); 111 112/* increases storage size for global variables */ 113void LispMoreGlobals(LispPackage*); 114 115#ifdef __GNUC__ 116static INLINE LispObj *LispDoGetVar(LispObj*); 117#endif 118static INLINE void LispDoAddVar(LispObj*, LispObj*); 119 120/* Helper for importing symbol(s) functions, 121 * Search for the specified object in the current package */ 122static INLINE LispObj *LispGetVarPack(LispObj*); 123 124/* create environment for function call */ 125static int LispMakeEnvironment(LispArgList*, LispObj*, LispObj*, int, int); 126 127 /* if not already in keyword package, move atom to keyword package */ 128static LispObj *LispCheckKeyword(LispObj*); 129 130 /* builtin backquote parsing */ 131static LispObj *LispEvalBackquoteObject(LispObj*, int, int); 132 /* used also by the bytecode compiler */ 133LispObj *LispEvalBackquote(LispObj*, int); 134 135 /* create or change object property */ 136void LispSetAtomObjectProperty(LispAtom*, LispObj*); 137 /* remove object property */ 138static void LispRemAtomObjectProperty(LispAtom*); 139 140 /* allocates a new LispProperty for the given atom */ 141static void LispAllocAtomProperty(LispAtom*); 142 /* Increment reference count of atom property */ 143static void LispIncrementAtomReference(LispAtom*); 144 /* Decrement reference count of atom property */ 145static void LispDecrementAtomReference(LispAtom*); 146 /* Removes all atom properties */ 147static void LispRemAtomAllProperties(LispAtom*); 148 149static LispObj *LispAtomPropertyFunction(LispAtom*, LispObj*, int); 150 151static INLINE void LispCheckMemLevel(void); 152 153void LispAllocSeg(LispObjSeg*, int); 154static INLINE void LispMark(LispObj*); 155 156/* functions, macros, setf methods, and structure definitions */ 157static INLINE void LispProt(LispObj*); 158 159static LispObj *LispCheckNeedProtect(LispObj*); 160 161static 162#ifdef SIGNALRETURNSINT 163int 164#else 165void 166#endif 167LispSignalHandler(int); 168 169/* 170 * Initialization 171 */ 172LispMac lisp__data; 173 174static LispObj lispunbound = {LispNil_t}; 175LispObj *UNBOUND = &lispunbound; 176 177static volatile int lisp__disable_int; 178static volatile int lisp__interrupted; 179 180LispObj *Okey, *Orest, *Ooptional, *Oaux, *Olambda; 181 182Atom_id Snil, St; 183Atom_id Saux, Skey, Soptional, Srest; 184Atom_id Satom, Ssymbol, Sinteger, Scharacter, Sstring, Slist, 185 Scons, Svector, Sarray, Sstruct, Skeyword, Sfunction, Spathname, 186 Srational, Sfloat, Scomplex, Sopaque, Sdefault; 187 188LispObj *Oformat, *Kunspecific; 189LispObj *Oexpand_setf_method; 190 191static LispProperty noproperty; 192LispProperty *NOPROPERTY = &noproperty; 193static int segsize, minfree; 194int pagesize, gcpro; 195 196static LispObjSeg objseg = {NULL, NIL}; 197static LispObjSeg atomseg = {NULL, NIL}; 198 199int LispArgList_t; 200 201LispFile *Stdout, *Stdin, *Stderr; 202 203static 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 609static 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. */ 630extern LispObj x_cons[8]; 631 632/* 633 * Implementation 634 */ 635static int 636LispGetPageSize(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 670void 671LispDestroy(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 739void 740LispContinuable(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 765void 766LispMessage(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 781void 782LispWarning(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 799void 800LispTopLevel(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 864void 865LispGC(LispObj *car, LispObj *cdr) 866{ 867 Lisp__GC(car, cdr); 868} 869 870static void 871Lisp__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 (atom = (LispAtom *)hash_iter_first(pack->atoms); 939 atom; 940 atom = (LispAtom *)hash_iter_next(pack->atoms)) { 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 } 954 } 955 956 /* protect environment */ 957 for (pentry = lisp__data.env.values, 958 eentry = pentry + lisp__data.env.length; 959 pentry < eentry; pentry++) 960 LispMark(*pentry); 961 962 /* protect multiple return values */ 963 for (pentry = lisp__data.returns.values, 964 eentry = pentry + lisp__data.returns.count; 965 pentry < eentry; pentry++) 966 LispMark(*pentry); 967 968 /* protect stack of arguments to builtin functions */ 969 for (pentry = lisp__data.stack.values, 970 eentry = pentry + lisp__data.stack.length; 971 pentry < eentry; pentry++) 972 LispMark(*pentry); 973 974 /* protect temporary data used by builtin functions */ 975 for (pentry = lisp__data.protect.objects, 976 eentry = pentry + lisp__data.protect.length; 977 pentry < eentry; pentry++) 978 LispMark(*pentry); 979 980 for (i = 0; i < sizeof(x_cons) / sizeof(x_cons[0]); i++) 981 x_cons[i].mark = 0; 982 983 LispMark(COD); 984#ifdef DEBUGGER 985 LispMark(DBG); 986 LispMark(BRK); 987#endif 988 LispMark(PRO); 989 LispMark(lisp__data.input_list); 990 LispMark(lisp__data.output_list); 991 LispMark(car); 992 LispMark(cdr); 993 994 for (j = 0; j < objseg.nsegs; j++) { 995 for (entry = objseg.objects[j], last = entry + segsize; 996 entry < last; entry++) { 997 if (entry->prot) 998 continue; 999 else if (entry->mark) 1000 entry->mark = 0; 1001 else { 1002 switch (XOBJECT_TYPE(entry)) { 1003 case LispString_t: 1004 free(THESTR(entry)); 1005 entry->type = LispCons_t; 1006 break; 1007 case LispStream_t: 1008 switch (entry->data.stream.type) { 1009 case LispStreamString: 1010 free(SSTREAMP(entry)->string); 1011 free(SSTREAMP(entry)); 1012 break; 1013 case LispStreamFile: 1014 if (FSTREAMP(entry)) 1015 LispFclose(FSTREAMP(entry)); 1016 break; 1017 case LispStreamPipe: 1018 /* XXX may need special handling if child hangs */ 1019 if (PSTREAMP(entry)) { 1020 if (IPSTREAMP(entry)) 1021 LispFclose(IPSTREAMP(entry)); 1022 if (OPSTREAMP(entry)) 1023 LispFclose(OPSTREAMP(entry)); 1024 /* don't bother with error stream, will also 1025 * freed in this GC call, maybe just out 1026 * of order */ 1027 if (PIDPSTREAMP(entry) > 0) { 1028 kill(PIDPSTREAMP(entry), SIGTERM); 1029 waitpid(PIDPSTREAMP(entry), NULL, 0); 1030 } 1031 free(PSTREAMP(entry)); 1032 } 1033 break; 1034 default: 1035 break; 1036 } 1037 entry->type = LispCons_t; 1038 break; 1039 case LispBignum_t: 1040 mpi_clear(entry->data.mp.integer); 1041 free(entry->data.mp.integer); 1042 entry->type = LispCons_t; 1043 break; 1044 case LispBigratio_t: 1045 mpr_clear(entry->data.mp.ratio); 1046 free(entry->data.mp.ratio); 1047 entry->type = LispCons_t; 1048 break; 1049 case LispLambda_t: 1050 if (!SYMBOLP(entry->data.lambda.name)) 1051 LispFreeArgList((LispArgList*) 1052 entry->data.lambda.name->data.opaque.data); 1053 entry->type = LispCons_t; 1054 break; 1055 case LispRegex_t: 1056 refree(entry->data.regex.regex); 1057 free(entry->data.regex.regex); 1058 entry->type = LispCons_t; 1059 break; 1060 case LispBytecode_t: 1061 free(entry->data.bytecode.bytecode->code); 1062 free(entry->data.bytecode.bytecode); 1063 entry->type = LispCons_t; 1064 break; 1065 case LispHashTable_t: 1066 LispFreeHashTable(entry->data.hash.table); 1067 entry->type = LispCons_t; 1068 break; 1069 case LispCons_t: 1070 break; 1071 default: 1072 entry->type = LispCons_t; 1073 break; 1074 } 1075 CDR(entry) = freeobj; 1076 freeobj = entry; 1077 ++nfree; 1078 } 1079 } 1080 } 1081 1082 objseg.nfree = nfree; 1083 objseg.freeobj = freeobj; 1084 1085 lisp__data.gc.immutablebits = 0; 1086 1087#ifdef DEBUG 1088 gettimeofday(&end, NULL); 1089 sec = end.tv_sec - start.tv_sec; 1090 msec = end.tv_usec - start.tv_usec; 1091 if (msec < 0) { 1092 --sec; 1093 msec += 1000000; 1094 } 1095 LispMessage("gc: " 1096 "%ld sec, %ld msec, " 1097 "%d recovered, %d free, %d protected, %d total", 1098 sec, msec, 1099 objseg.nfree - count, objseg.nfree, 1100 objseg.nobjs - objseg.nfree, objseg.nobjs); 1101#else 1102 if (lisp__data.gc.timebits) { 1103 gettimeofday(&end, NULL); 1104 if ((msec = end.tv_usec - start.tv_usec) < 0) 1105 msec += 1000000; 1106 lisp__data.gc.gctime += msec; 1107 } 1108#endif 1109 1110 ENABLE_INTERRUPTS(); 1111} 1112 1113static INLINE void 1114LispCheckMemLevel(void) 1115{ 1116 int i; 1117 1118 /* Check for a free slot before the end. */ 1119 for (i = lisp__data.mem.index; i < lisp__data.mem.level; i++) 1120 if (lisp__data.mem.mem[i] == NULL) { 1121 lisp__data.mem.index = i; 1122 return; 1123 } 1124 1125 /* Check for a free slot in the beginning */ 1126 for (i = 0; i < lisp__data.mem.index; i++) 1127 if (lisp__data.mem.mem[i] == NULL) { 1128 lisp__data.mem.index = i; 1129 return; 1130 } 1131 1132 lisp__data.mem.index = lisp__data.mem.level; 1133 ++lisp__data.mem.level; 1134 if (lisp__data.mem.index < lisp__data.mem.space) 1135 /* There is free space to store pointer. */ 1136 return; 1137 else { 1138 void **ptr = (void**)realloc(lisp__data.mem.mem, 1139 (lisp__data.mem.space + 16) * 1140 sizeof(void*)); 1141 1142 if (ptr == NULL) 1143 LispDestroy("out of memory"); 1144 lisp__data.mem.mem = ptr; 1145 lisp__data.mem.space += 16; 1146 } 1147} 1148 1149void 1150LispMused(void *pointer) 1151{ 1152 int i; 1153 1154 DISABLE_INTERRUPTS(); 1155 for (i = lisp__data.mem.index; i >= 0; i--) 1156 if (lisp__data.mem.mem[i] == pointer) { 1157 lisp__data.mem.mem[i] = NULL; 1158 lisp__data.mem.index = i; 1159 goto mused_done; 1160 } 1161 1162 for (i = lisp__data.mem.level - 1; i > lisp__data.mem.index; i--) 1163 if (lisp__data.mem.mem[i] == pointer) { 1164 lisp__data.mem.mem[i] = NULL; 1165 lisp__data.mem.index = i; 1166 break; 1167 } 1168 1169mused_done: 1170 ENABLE_INTERRUPTS(); 1171} 1172 1173void * 1174LispMalloc(size_t size) 1175{ 1176 void *pointer; 1177 1178 DISABLE_INTERRUPTS(); 1179 LispCheckMemLevel(); 1180 if ((pointer = malloc(size)) == NULL) 1181 LispDestroy("out of memory, couldn't allocate %lu bytes", 1182 (unsigned long)size); 1183 1184 lisp__data.mem.mem[lisp__data.mem.index] = pointer; 1185 ENABLE_INTERRUPTS(); 1186 1187 return (pointer); 1188} 1189 1190void * 1191LispCalloc(size_t nmemb, size_t size) 1192{ 1193 void *pointer; 1194 1195 DISABLE_INTERRUPTS(); 1196 LispCheckMemLevel(); 1197 if ((pointer = calloc(nmemb, size)) == NULL) 1198 LispDestroy("out of memory, couldn't allocate %lu bytes", 1199 (unsigned long)size); 1200 1201 lisp__data.mem.mem[lisp__data.mem.index] = pointer; 1202 ENABLE_INTERRUPTS(); 1203 1204 return (pointer); 1205} 1206 1207void * 1208LispRealloc(void *pointer, size_t size) 1209{ 1210 void *ptr; 1211 int i; 1212 1213 DISABLE_INTERRUPTS(); 1214 if (pointer != NULL) { 1215 for (i = lisp__data.mem.index; i >= 0; i--) 1216 if (lisp__data.mem.mem[i] == pointer) 1217 goto index_found; 1218 1219 for (i = lisp__data.mem.index + 1; i < lisp__data.mem.level; i++) 1220 if (lisp__data.mem.mem[i] == pointer) 1221 goto index_found; 1222 1223 } 1224 LispCheckMemLevel(); 1225 i = lisp__data.mem.index; 1226 1227index_found: 1228 if ((ptr = realloc(pointer, size)) == NULL) 1229 LispDestroy("out of memory, couldn't realloc"); 1230 1231 lisp__data.mem.mem[i] = ptr; 1232 ENABLE_INTERRUPTS(); 1233 1234 return (ptr); 1235} 1236 1237char * 1238LispStrdup(char *str) 1239{ 1240 char *ptr = LispMalloc(strlen(str) + 1); 1241 1242 strcpy(ptr, str); 1243 1244 return (ptr); 1245} 1246 1247void 1248LispFree(void *pointer) 1249{ 1250 int i; 1251 1252 DISABLE_INTERRUPTS(); 1253 for (i = lisp__data.mem.index; i >= 0; i--) 1254 if (lisp__data.mem.mem[i] == pointer) { 1255 lisp__data.mem.mem[i] = NULL; 1256 lisp__data.mem.index = i; 1257 goto free_done; 1258 } 1259 1260 for (i = lisp__data.mem.level - 1; i > lisp__data.mem.index; i--) 1261 if (lisp__data.mem.mem[i] == pointer) { 1262 lisp__data.mem.mem[i] = NULL; 1263 lisp__data.mem.index = i; 1264 break; 1265 } 1266 1267free_done: 1268 free(pointer); 1269 ENABLE_INTERRUPTS(); 1270} 1271 1272LispObj * 1273LispSetVariable(LispObj *var, LispObj *val, char *fname, int eval) 1274{ 1275 if (!SYMBOLP(var)) 1276 LispDestroy("%s: %s is not a symbol", fname, STROBJ(var)); 1277 if (eval) 1278 val = EVAL(val); 1279 1280 return (LispSetVar(var, val)); 1281} 1282 1283int 1284LispRegisterOpaqueType(char *desc) 1285{ 1286 int length; 1287 LispOpaque *opaque; 1288 1289 length = strlen(desc); 1290 opaque = (LispOpaque *)hash_check(lisp__data.opqs, desc, length); 1291 1292 if (opaque == NULL) { 1293 opaque = (LispOpaque*)LispMalloc(sizeof(LispOpaque)); 1294 opaque->desc = (hash_key*)LispCalloc(1, sizeof(hash_key)); 1295 opaque->desc->value = LispStrdup(desc); 1296 opaque->desc->length = length; 1297 hash_put(lisp__data.opqs, (hash_entry *)opaque); 1298 LispMused(opaque->desc->value); 1299 LispMused(opaque->desc); 1300 LispMused(opaque); 1301 opaque->type = ++lisp__data.opaque; 1302 } 1303 1304 return (opaque->type); 1305} 1306 1307char * 1308LispIntToOpaqueType(int type) 1309{ 1310 LispOpaque *opaque; 1311 1312 if (type) { 1313 for (opaque = (LispOpaque *)hash_iter_first(lisp__data.opqs); 1314 opaque; 1315 opaque = (LispOpaque *)hash_iter_next(lisp__data.opqs)) { 1316 if (opaque->type == type) 1317 return (opaque->desc->value); 1318 } 1319 LispDestroy("Opaque type %d not registered", type); 1320 } 1321 1322 return (Snil->value); 1323} 1324 1325hash_key * 1326LispGetAtomKey(char *string, int perm) 1327{ 1328 int length; 1329 hash_entry *entry; 1330 1331 length = strlen(string); 1332 entry = hash_check(lisp__data.strings, string, length); 1333 if (entry == NULL) { 1334 entry = LispCalloc(1, sizeof(hash_entry)); 1335 entry->key = LispCalloc(1, sizeof(hash_key)); 1336 if (perm) 1337 entry->key->value = string; 1338 else 1339 entry->key->value = LispStrdup(string); 1340 entry->key->length = length; 1341 1342 hash_put(lisp__data.strings, entry); 1343 if (!perm) 1344 LispMused(entry->key->value); 1345 LispMused(entry->key); 1346 LispMused(entry); 1347 } 1348 1349 return (entry->key); 1350} 1351 1352LispAtom * 1353LispDoGetAtom(char *str, int perm) 1354{ 1355 int length; 1356 LispAtom *atom; 1357 1358 length = strlen(str); 1359 atom = (LispAtom *)hash_check(lisp__data.pack->atoms, str, length); 1360 1361 if (atom == NULL) { 1362 atom = (LispAtom*)LispCalloc(1, sizeof(LispAtom)); 1363 atom->key = LispGetAtomKey(str, perm); 1364 hash_put(lisp__data.pack->atoms, (hash_entry *)atom); 1365 atom->property = NOPROPERTY; 1366 LispMused(atom); 1367 } 1368 1369 return (atom); 1370} 1371 1372static void 1373LispAllocAtomProperty(LispAtom *atom) 1374{ 1375 LispProperty *property; 1376 1377 if (atom->property != NOPROPERTY) 1378 LispDestroy("internal error at ALLOC-ATOM-PROPERTY"); 1379 1380 property = LispCalloc(1, sizeof(LispProperty)); 1381 LispMused(property); 1382 atom->property = property; 1383 property->package = lisp__data.pack; 1384 if (atom->package == NULL) 1385 atom->package = PACKAGE; 1386 1387 LispIncrementAtomReference(atom); 1388} 1389 1390static void 1391LispIncrementAtomReference(LispAtom *atom) 1392{ 1393 if (atom->property != NOPROPERTY) 1394 /* if atom->property is NOPROPERTY, this is an unbound symbol */ 1395 ++atom->property->refcount; 1396} 1397 1398/* Assumes atom property is not NOPROPERTY */ 1399static void 1400LispDecrementAtomReference(LispAtom *atom) 1401{ 1402 if (atom->property == NOPROPERTY) 1403 /* if atom->property is NOPROPERTY, this is an unbound symbol */ 1404 return; 1405 1406 if (atom->property->refcount <= 0) 1407 LispDestroy("internal error at DECREMENT-ATOM-REFERENCE"); 1408 1409 --atom->property->refcount; 1410 1411 if (atom->property->refcount == 0) { 1412 LispRemAtomAllProperties(atom); 1413 free(atom->property); 1414 atom->property = NOPROPERTY; 1415 } 1416} 1417 1418static void 1419LispRemAtomAllProperties(LispAtom *atom) 1420{ 1421 if (atom->property != NOPROPERTY) { 1422 if (atom->a_object) 1423 LispRemAtomObjectProperty(atom); 1424 if (atom->a_function) { 1425 lisp__data.gc.immutablebits = 1; 1426 LispRemAtomFunctionProperty(atom); 1427 } 1428 else if (atom->a_compiled) { 1429 lisp__data.gc.immutablebits = 1; 1430 LispRemAtomCompiledProperty(atom); 1431 } 1432 else if (atom->a_builtin) { 1433 lisp__data.gc.immutablebits = 1; 1434 LispRemAtomBuiltinProperty(atom); 1435 } 1436 if (atom->a_defsetf) { 1437 lisp__data.gc.immutablebits = 1; 1438 LispRemAtomSetfProperty(atom); 1439 } 1440 if (atom->a_defstruct) { 1441 lisp__data.gc.immutablebits = 1; 1442 LispRemAtomStructProperty(atom); 1443 } 1444 } 1445} 1446 1447void 1448LispSetAtomObjectProperty(LispAtom *atom, LispObj *object) 1449{ 1450 if (atom->property == NOPROPERTY) 1451 LispAllocAtomProperty(atom); 1452 else if (atom->watch) { 1453 if (atom->object == lisp__data.package) { 1454 if (!PACKAGEP(object)) 1455 LispDestroy("Symbol %s must be a package, not %s", 1456 ATOMID(lisp__data.package)->value, STROBJ(object)); 1457 lisp__data.pack = object->data.package.package; 1458 } 1459 } 1460 1461 atom->a_object = 1; 1462 SETVALUE(atom, object); 1463} 1464 1465static void 1466LispRemAtomObjectProperty(LispAtom *atom) 1467{ 1468 if (atom->a_object) { 1469 atom->a_object = 0; 1470 atom->property->value = NULL; 1471 } 1472} 1473 1474void 1475LispSetAtomCompiledProperty(LispAtom *atom, LispObj *bytecode) 1476{ 1477 if (atom->property == NOPROPERTY) 1478 LispAllocAtomProperty(atom); 1479 1480 lisp__data.gc.immutablebits = 1; 1481 if (atom->a_builtin) { 1482 atom->a_builtin = 0; 1483 LispFreeArgList(atom->property->alist); 1484 } 1485 else 1486 atom->a_function = 0; 1487 atom->a_compiled = 1; 1488 atom->property->fun.function = bytecode; 1489} 1490 1491void 1492LispRemAtomCompiledProperty(LispAtom *atom) 1493{ 1494 if (atom->a_compiled) { 1495 lisp__data.gc.immutablebits = 1; 1496 atom->property->fun.function = NULL; 1497 atom->a_compiled = 0; 1498 LispFreeArgList(atom->property->alist); 1499 atom->property->alist = NULL; 1500 } 1501} 1502 1503void 1504LispSetAtomFunctionProperty(LispAtom *atom, LispObj *function, 1505 LispArgList *alist) 1506{ 1507 if (atom->property == NOPROPERTY) 1508 LispAllocAtomProperty(atom); 1509 1510 lisp__data.gc.immutablebits = 1; 1511 if (atom->a_function == 0 && atom->a_builtin == 0 && atom->a_compiled == 0) 1512 atom->a_function = 1; 1513 else { 1514 if (atom->a_builtin) { 1515 atom->a_builtin = 0; 1516 LispFreeArgList(atom->property->alist); 1517 } 1518 else 1519 atom->a_compiled = 0; 1520 atom->a_function = 1; 1521 } 1522 1523 atom->property->fun.function = function; 1524 atom->property->alist = alist; 1525} 1526 1527void 1528LispRemAtomFunctionProperty(LispAtom *atom) 1529{ 1530 if (atom->a_function) { 1531 lisp__data.gc.immutablebits = 1; 1532 atom->property->fun.function = NULL; 1533 atom->a_function = 0; 1534 LispFreeArgList(atom->property->alist); 1535 atom->property->alist = NULL; 1536 } 1537} 1538 1539void 1540LispSetAtomBuiltinProperty(LispAtom *atom, LispBuiltin *builtin, 1541 LispArgList *alist) 1542{ 1543 if (atom->property == NOPROPERTY) 1544 LispAllocAtomProperty(atom); 1545 1546 lisp__data.gc.immutablebits = 1; 1547 if (atom->a_builtin == 0 && atom->a_function == 0) 1548 atom->a_builtin = 1; 1549 else { 1550 if (atom->a_function) { 1551 atom->a_function = 0; 1552 LispFreeArgList(atom->property->alist); 1553 } 1554 } 1555 1556 atom->property->fun.builtin = builtin; 1557 atom->property->alist = alist; 1558} 1559 1560void 1561LispRemAtomBuiltinProperty(LispAtom *atom) 1562{ 1563 if (atom->a_builtin) { 1564 lisp__data.gc.immutablebits = 1; 1565 atom->property->fun.function = NULL; 1566 atom->a_builtin = 0; 1567 LispFreeArgList(atom->property->alist); 1568 atom->property->alist = NULL; 1569 } 1570} 1571 1572void 1573LispSetAtomSetfProperty(LispAtom *atom, LispObj *setf, LispArgList *alist) 1574{ 1575 if (atom->property == NOPROPERTY) 1576 LispAllocAtomProperty(atom); 1577 1578 lisp__data.gc.immutablebits = 1; 1579 if (atom->a_defsetf) 1580 LispFreeArgList(atom->property->salist); 1581 1582 atom->a_defsetf = 1; 1583 atom->property->setf = setf; 1584 atom->property->salist = alist; 1585} 1586 1587void 1588LispRemAtomSetfProperty(LispAtom *atom) 1589{ 1590 if (atom->a_defsetf) { 1591 lisp__data.gc.immutablebits = 1; 1592 atom->property->setf = NULL; 1593 atom->a_defsetf = 0; 1594 LispFreeArgList(atom->property->salist); 1595 atom->property->salist = NULL; 1596 } 1597} 1598 1599void 1600LispSetAtomStructProperty(LispAtom *atom, LispObj *def, int fun) 1601{ 1602 if (fun > 0xff) 1603 /* Not suported by the bytecode compiler... */ 1604 LispDestroy("SET-ATOM-STRUCT-PROPERTY: " 1605 "more than 256 fields not supported"); 1606 1607 if (atom->property == NOPROPERTY) 1608 LispAllocAtomProperty(atom); 1609 1610 lisp__data.gc.immutablebits = 1; 1611 atom->a_defstruct = 1; 1612 atom->property->structure.definition = def; 1613 atom->property->structure.function = fun; 1614} 1615 1616void 1617LispRemAtomStructProperty(LispAtom *atom) 1618{ 1619 if (atom->a_defstruct) { 1620 lisp__data.gc.immutablebits = 1; 1621 atom->property->structure.definition = NULL; 1622 atom->a_defstruct = 0; 1623 } 1624} 1625 1626LispAtom * 1627LispGetAtom(char *str) 1628{ 1629 return (LispDoGetAtom(str, 0)); 1630} 1631 1632LispAtom * 1633LispGetPermAtom(char *str) 1634{ 1635 return (LispDoGetAtom(str, 1)); 1636} 1637 1638#define GET_PROPERTY 0 1639#define ADD_PROPERTY 1 1640#define REM_PROPERTY 2 1641static LispObj * 1642LispAtomPropertyFunction(LispAtom *atom, LispObj *key, int function) 1643{ 1644 LispObj *list = NIL, *result = NIL; 1645 1646 if (function == ADD_PROPERTY) { 1647 if (atom->property == NOPROPERTY) 1648 LispAllocAtomProperty(atom); 1649 if (atom->property->properties == NULL) { 1650 atom->a_property = 1; 1651 atom->property->properties = NIL; 1652 } 1653 } 1654 1655 if (atom->a_property) { 1656 LispObj *base; 1657 1658 for (base = list = atom->property->properties; 1659 CONSP(list); 1660 list = CDR(list)) { 1661 if (key == CAR(list)) { 1662 result = CDR(list); 1663 break; 1664 } 1665 base = list; 1666 list = CDR(list); 1667 if (!CONSP(list)) 1668 LispDestroy("%s: %s has an odd property list length", 1669 STROBJ(atom->object), 1670 function == REM_PROPERTY ? "REMPROP" : "GET"); 1671 } 1672 if (CONSP(list) && function == REM_PROPERTY) { 1673 if (!CONSP(CDR(list))) 1674 LispDestroy("REMPROP: %s has an odd property list length", 1675 STROBJ(atom->object)); 1676 if (base == list) 1677 atom->property->properties = CDDR(list); 1678 else 1679 RPLACD(CDR(base), CDDR(list)); 1680 } 1681 } 1682 1683 if (!CONSP(list)) { 1684 if (function == ADD_PROPERTY) { 1685 atom->property->properties = 1686 CONS(key, CONS(NIL, atom->property->properties)); 1687 result = CDR(atom->property->properties); 1688 } 1689 } 1690 else if (function == REM_PROPERTY) 1691 result = T; 1692 1693 return (result); 1694} 1695 1696LispObj * 1697LispGetAtomProperty(LispAtom *atom, LispObj *key) 1698{ 1699 return (LispAtomPropertyFunction(atom, key, GET_PROPERTY)); 1700} 1701 1702LispObj * 1703LispPutAtomProperty(LispAtom *atom, LispObj *key, LispObj *value) 1704{ 1705 LispObj *result = LispAtomPropertyFunction(atom, key, ADD_PROPERTY); 1706 1707 RPLACA(result, value); 1708 1709 return (result); 1710} 1711 1712LispObj * 1713LispRemAtomProperty(LispAtom *atom, LispObj *key) 1714{ 1715 return (LispAtomPropertyFunction(atom, key, REM_PROPERTY)); 1716} 1717 1718LispObj * 1719LispReplaceAtomPropertyList(LispAtom *atom, LispObj *list) 1720{ 1721 if (atom->property == NOPROPERTY) 1722 LispAllocAtomProperty(atom); 1723 if (atom->property->properties == NULL) 1724 atom->a_property = 1; 1725 atom->property->properties = list; 1726 1727 return (list); 1728} 1729#undef GET_PROPERTY 1730#undef ADD_PROPERTY 1731#undef REM_PROPERTY 1732 1733 1734/* Used to make sure that when defining a function like: 1735 * (defun my-function (... &key key1 key2 key3 ...) 1736 * key1, key2, and key3 will be in the keyword package 1737 */ 1738static LispObj * 1739LispCheckKeyword(LispObj *keyword) 1740{ 1741 if (KEYWORDP(keyword)) 1742 return (keyword); 1743 1744 return (KEYWORD(ATOMID(keyword)->value)); 1745} 1746 1747void 1748LispUseArgList(LispArgList *alist) 1749{ 1750 if (alist->normals.num_symbols) 1751 LispMused(alist->normals.symbols); 1752 if (alist->optionals.num_symbols) { 1753 LispMused(alist->optionals.symbols); 1754 LispMused(alist->optionals.defaults); 1755 LispMused(alist->optionals.sforms); 1756 } 1757 if (alist->keys.num_symbols) { 1758 LispMused(alist->keys.symbols); 1759 LispMused(alist->keys.defaults); 1760 LispMused(alist->keys.sforms); 1761 LispMused(alist->keys.keys); 1762 } 1763 if (alist->auxs.num_symbols) { 1764 LispMused(alist->auxs.symbols); 1765 LispMused(alist->auxs.initials); 1766 } 1767 LispMused(alist); 1768} 1769 1770void 1771LispFreeArgList(LispArgList *alist) 1772{ 1773 if (alist->normals.num_symbols) 1774 LispFree(alist->normals.symbols); 1775 if (alist->optionals.num_symbols) { 1776 LispFree(alist->optionals.symbols); 1777 LispFree(alist->optionals.defaults); 1778 LispFree(alist->optionals.sforms); 1779 } 1780 if (alist->keys.num_symbols) { 1781 LispFree(alist->keys.symbols); 1782 LispFree(alist->keys.defaults); 1783 LispFree(alist->keys.sforms); 1784 LispFree(alist->keys.keys); 1785 } 1786 if (alist->auxs.num_symbols) { 1787 LispFree(alist->auxs.symbols); 1788 LispFree(alist->auxs.initials); 1789 } 1790 LispFree(alist); 1791} 1792 1793static LispObj * 1794LispCheckNeedProtect(LispObj *object) 1795{ 1796 if (object) { 1797 switch (OBJECT_TYPE(object)) { 1798 case LispNil_t: 1799 case LispAtom_t: 1800 case LispFunction_t: 1801 case LispFixnum_t: 1802 case LispSChar_t: 1803 return (NULL); 1804 default: 1805 return (object); 1806 } 1807 } 1808 return (NULL); 1809} 1810 1811LispObj * 1812LispListProtectedArguments(LispArgList *alist) 1813{ 1814 int i; 1815 GC_ENTER(); 1816 LispObj *arguments, *cons, *obj, *prev; 1817 1818 arguments = cons = prev = NIL; 1819 for (i = 0; i < alist->optionals.num_symbols; i++) { 1820 if ((obj = LispCheckNeedProtect(alist->optionals.defaults[i])) != NULL) { 1821 if (arguments == NIL) { 1822 arguments = cons = prev = CONS(obj, NIL); 1823 GC_PROTECT(arguments); 1824 } 1825 else { 1826 RPLACD(cons, CONS(obj, NIL)); 1827 prev = cons; 1828 cons = CDR(cons); 1829 } 1830 } 1831 } 1832 for (i = 0; i < alist->keys.num_symbols; i++) { 1833 if ((obj = LispCheckNeedProtect(alist->keys.defaults[i])) != NULL) { 1834 if (arguments == NIL) { 1835 arguments = cons = prev = CONS(obj, NIL); 1836 GC_PROTECT(arguments); 1837 } 1838 else { 1839 RPLACD(cons, CONS(obj, NIL)); 1840 prev = cons; 1841 cons = CDR(cons); 1842 } 1843 } 1844 } 1845 for (i = 0; i < alist->auxs.num_symbols; i++) { 1846 if ((obj = LispCheckNeedProtect(alist->auxs.initials[i])) != NULL) { 1847 if (arguments == NIL) { 1848 arguments = cons = prev = CONS(obj, NIL); 1849 GC_PROTECT(arguments); 1850 } 1851 else { 1852 RPLACD(cons, CONS(obj, NIL)); 1853 prev = cons; 1854 cons = CDR(cons); 1855 } 1856 } 1857 } 1858 GC_LEAVE(); 1859 1860 /* Don't add a NIL cell at the end, to save some space */ 1861 if (arguments != NIL) { 1862 if (arguments == cons) 1863 arguments = CAR(cons); 1864 else 1865 CDR(prev) = CAR(cons); 1866 } 1867 1868 return (arguments); 1869} 1870 1871LispArgList * 1872LispCheckArguments(LispFunType type, LispObj *list, char *name, int builtin) 1873{ 1874 static char *types[4] = {"LAMBDA-LIST", "FUNCTION", "MACRO", "SETF-METHOD"}; 1875 static char *fnames[4] = {"LAMBDA", "DEFUN", "DEFMACRO", "DEFSETF"}; 1876#define IKEY 0 1877#define IOPTIONAL 1 1878#define IREST 2 1879#define IAUX 3 1880 static char *keys[4] = {"&KEY", "&OPTIONAL", "&REST", "&AUX"}; 1881 int rest, optional, key, aux, count; 1882 LispArgList *alist; 1883 LispObj *spec, *sform, *defval, *default_value; 1884 char description[8], *desc; 1885 1886/* If LispRealloc fails, the previous memory will be released 1887 * in LispTopLevel, unless LispMused was called on the pointer */ 1888#define REALLOC_OBJECTS(pointer, count) \ 1889 pointer = LispRealloc(pointer, (count) * sizeof(LispObj*)) 1890 1891 alist = LispCalloc(1, sizeof(LispArgList)); 1892 if (!CONSP(list)) { 1893 if (list != NIL) 1894 LispDestroy("%s %s: %s cannot be a %s argument list", 1895 fnames[type], name, STROBJ(list), types[type]); 1896 alist->description = GETATOMID("")->value; 1897 1898 return (alist); 1899 } 1900 1901 default_value = builtin ? UNSPEC : NIL; 1902 1903 description[0] = '\0'; 1904 desc = description; 1905 rest = optional = key = aux = 0; 1906 for (; CONSP(list); list = CDR(list)) { 1907 spec = CAR(list); 1908 1909 if (CONSP(spec)) { 1910 if (builtin) 1911 LispDestroy("builtin function argument cannot have default value"); 1912 if (aux) { 1913 if (!SYMBOLP(CAR(spec)) || 1914 (CDR(spec) != NIL && CDDR(spec) != NIL)) 1915 LispDestroy("%s %s: bad &AUX argument %s", 1916 fnames[type], name, STROBJ(spec)); 1917 defval = CDR(spec) != NIL ? CADR(spec) : NIL; 1918 count = alist->auxs.num_symbols; 1919 REALLOC_OBJECTS(alist->auxs.symbols, count + 1); 1920 REALLOC_OBJECTS(alist->auxs.initials, count + 1); 1921 alist->auxs.symbols[count] = CAR(spec); 1922 alist->auxs.initials[count] = defval; 1923 ++alist->auxs.num_symbols; 1924 if (count == 0) 1925 *desc++ = 'a'; 1926 ++alist->num_arguments; 1927 } 1928 else if (rest) 1929 LispDestroy("%s %s: syntax error parsing %s", 1930 fnames[type], name, keys[IREST]); 1931 else if (key) { 1932 LispObj *akey = CAR(spec); 1933 1934 defval = default_value; 1935 sform = NULL; 1936 if (CONSP(akey)) { 1937 /* check for special case, as in: 1938 * (defun a (&key ((key name) 'default-value)) name) 1939 * (a 'key 'test) => TEST 1940 * (a) => DEFAULT-VALUE 1941 */ 1942 if (!SYMBOLP(CAR(akey)) || !CONSP(CDR(akey)) || 1943 !SYMBOLP(CADR(akey)) || CDDR(akey) != NIL || 1944 (CDR(spec) != NIL && CDDR(spec) != NIL)) 1945 LispDestroy("%s %s: bad special &KEY %s", 1946 fnames[type], name, STROBJ(spec)); 1947 if (CDR(spec) != NIL) 1948 defval = CADR(spec); 1949 spec = CADR(akey); 1950 akey = CAR(akey); 1951 } 1952 else { 1953 akey = NULL; 1954 1955 if (!SYMBOLP(CAR(spec))) 1956 LispDestroy("%s %s: %s cannot be a %s argument name", 1957 fnames[type], name, 1958 STROBJ(CAR(spec)), types[type]); 1959 /* check if default value provided, and optionally a `svar' */ 1960 else if (CDR(spec) != NIL && (!CONSP(CDR(spec)) || 1961 (CDDR(spec) != NIL && 1962 (!SYMBOLP(CAR(CDDR(spec))) || 1963 CDR(CDDR(spec)) != NIL)))) 1964 LispDestroy("%s %s: bad argument specification %s", 1965 fnames[type], name, STROBJ(spec)); 1966 if (CONSP(CDR(spec))) { 1967 defval = CADR(spec); 1968 if (CONSP(CDDR(spec))) 1969 sform = CAR(CDDR(spec)); 1970 } 1971 /* Add to keyword package, and set the keyword in the 1972 * argument list, so that a function argument keyword 1973 * will reference the same object, and make comparison 1974 * simpler. */ 1975 spec = LispCheckKeyword(CAR(spec)); 1976 } 1977 1978 count = alist->keys.num_symbols; 1979 REALLOC_OBJECTS(alist->keys.keys, count + 1); 1980 REALLOC_OBJECTS(alist->keys.defaults, count + 1); 1981 REALLOC_OBJECTS(alist->keys.sforms, count + 1); 1982 REALLOC_OBJECTS(alist->keys.symbols, count + 1); 1983 alist->keys.symbols[count] = spec; 1984 alist->keys.defaults[count] = defval; 1985 alist->keys.sforms[count] = sform; 1986 alist->keys.keys[count] = akey; 1987 ++alist->keys.num_symbols; 1988 if (count == 0) 1989 *desc++ = 'k'; 1990 alist->num_arguments += 1 + (sform != NULL); 1991 } 1992 else if (optional) { 1993 defval = default_value; 1994 sform = NULL; 1995 1996 if (!SYMBOLP(CAR(spec))) 1997 LispDestroy("%s %s: %s cannot be a %s argument name", 1998 fnames[type], name, 1999 STROBJ(CAR(spec)), types[type]); 2000 /* check if default value provided, and optionally a `svar' */ 2001 else if (CDR(spec) != NIL && (!CONSP(CDR(spec)) || 2002 (CDDR(spec) != NIL && 2003 (!SYMBOLP(CAR(CDDR(spec))) || 2004 CDR(CDDR(spec)) != NIL)))) 2005 LispDestroy("%s %s: bad argument specification %s", 2006 fnames[type], name, STROBJ(spec)); 2007 if (CONSP(CDR(spec))) { 2008 defval = CADR(spec); 2009 if (CONSP(CDDR(spec))) 2010 sform = CAR(CDDR(spec)); 2011 } 2012 spec = CAR(spec); 2013 2014 count = alist->optionals.num_symbols; 2015 REALLOC_OBJECTS(alist->optionals.symbols, count + 1); 2016 REALLOC_OBJECTS(alist->optionals.defaults, count + 1); 2017 REALLOC_OBJECTS(alist->optionals.sforms, count + 1); 2018 alist->optionals.symbols[count] = spec; 2019 alist->optionals.defaults[count] = defval; 2020 alist->optionals.sforms[count] = sform; 2021 ++alist->optionals.num_symbols; 2022 if (count == 0) 2023 *desc++ = 'o'; 2024 alist->num_arguments += 1 + (sform != NULL); 2025 } 2026 2027 /* Normal arguments cannot have default value */ 2028 else 2029 LispDestroy("%s %s: syntax error parsing %s", 2030 fnames[type], name, STROBJ(spec)); 2031 } 2032 2033 /* spec must be an atom, excluding keywords */ 2034 else if (!SYMBOLP(spec) || KEYWORDP(spec)) 2035 LispDestroy("%s %s: %s cannot be a %s argument", 2036 fnames[type], name, STROBJ(spec), types[type]); 2037 else { 2038 Atom_id atom = ATOMID(spec); 2039 2040 if (atom->value[0] == '&') { 2041 if (atom == Srest) { 2042 if (rest || aux || CDR(list) == NIL || !SYMBOLP(CADR(list)) 2043 /* only &aux allowed after &rest */ 2044 || (CDDR(list) != NIL && !SYMBOLP(CAR(CDDR(list))) && 2045 ATOMID(CAR(CDDR(list))) != Saux)) 2046 LispDestroy("%s %s: syntax error parsing %s", 2047 fnames[type], name, ATOMID(spec)->value); 2048 if (key) 2049 LispDestroy("%s %s: %s not allowed after %s", 2050 fnames[type], name, keys[IREST], keys[IKEY]); 2051 rest = 1; 2052 continue; 2053 } 2054 2055 else if (atom == Skey) { 2056 if (rest || aux) 2057 LispDestroy("%s %s: %s not allowed after %s", 2058 fnames[type], name, ATOMID(spec)->value, 2059 rest ? keys[IREST] : keys[IAUX]); 2060 key = 1; 2061 continue; 2062 } 2063 2064 else if (atom == Soptional) { 2065 if (rest || optional || aux || key) 2066 LispDestroy("%s %s: %s not allowed after %s", 2067 fnames[type], name, ATOMID(spec)->value, 2068 rest ? keys[IREST] : 2069 optional ? 2070 keys[IOPTIONAL] : 2071 aux ? keys[IAUX] : keys[IKEY]); 2072 optional = 1; 2073 continue; 2074 } 2075 2076 else if (atom == Saux) { 2077 /* &AUX must be the last keyword parameter */ 2078 if (aux) 2079 LispDestroy("%s %s: syntax error parsing %s", 2080 fnames[type], name, ATOMID(spec)->value); 2081 else if (builtin) 2082 LispDestroy("builtin function cannot have &AUX arguments"); 2083 aux = 1; 2084 continue; 2085 } 2086 2087 /* Untill more lambda-list keywords supported, don't allow 2088 * argument names starting with the '&' character */ 2089 else 2090 LispDestroy("%s %s: %s not allowed/implemented", 2091 fnames[type], name, ATOMID(spec)->value); 2092 } 2093 2094 /* Add argument to alist */ 2095 if (aux) { 2096 count = alist->auxs.num_symbols; 2097 REALLOC_OBJECTS(alist->auxs.symbols, count + 1); 2098 REALLOC_OBJECTS(alist->auxs.initials, count + 1); 2099 alist->auxs.symbols[count] = spec; 2100 alist->auxs.initials[count] = default_value; 2101 ++alist->auxs.num_symbols; 2102 if (count == 0) 2103 *desc++ = 'a'; 2104 ++alist->num_arguments; 2105 } 2106 else if (rest) { 2107 alist->rest = spec; 2108 *desc++ = 'r'; 2109 ++alist->num_arguments; 2110 } 2111 else if (key) { 2112 /* Add to keyword package, and set the keyword in the 2113 * argument list, so that a function argument keyword 2114 * will reference the same object, and make comparison 2115 * simpler. */ 2116 spec = LispCheckKeyword(spec); 2117 count = alist->keys.num_symbols; 2118 REALLOC_OBJECTS(alist->keys.keys, count + 1); 2119 REALLOC_OBJECTS(alist->keys.defaults, count + 1); 2120 REALLOC_OBJECTS(alist->keys.sforms, count + 1); 2121 REALLOC_OBJECTS(alist->keys.symbols, count + 1); 2122 alist->keys.symbols[count] = spec; 2123 alist->keys.defaults[count] = default_value; 2124 alist->keys.sforms[count] = NULL; 2125 alist->keys.keys[count] = NULL; 2126 ++alist->keys.num_symbols; 2127 if (count == 0) 2128 *desc++ = 'k'; 2129 ++alist->num_arguments; 2130 } 2131 else if (optional) { 2132 count = alist->optionals.num_symbols; 2133 REALLOC_OBJECTS(alist->optionals.symbols, count + 1); 2134 REALLOC_OBJECTS(alist->optionals.defaults, count + 1); 2135 REALLOC_OBJECTS(alist->optionals.sforms, count + 1); 2136 alist->optionals.symbols[count] = spec; 2137 alist->optionals.defaults[count] = default_value; 2138 alist->optionals.sforms[count] = NULL; 2139 ++alist->optionals.num_symbols; 2140 if (count == 0) 2141 *desc++ = 'o'; 2142 ++alist->num_arguments; 2143 } 2144 else { 2145 count = alist->normals.num_symbols; 2146 REALLOC_OBJECTS(alist->normals.symbols, count + 1); 2147 alist->normals.symbols[count] = spec; 2148 ++alist->normals.num_symbols; 2149 if (count == 0) 2150 *desc++ = '.'; 2151 ++alist->num_arguments; 2152 } 2153 } 2154 } 2155 2156 /* Check for dotted argument list */ 2157 if (list != NIL) 2158 LispDestroy("%s %s: %s cannot end %s arguments", 2159 fnames[type], name, STROBJ(list), types[type]); 2160 2161 *desc = '\0'; 2162 alist->description = LispGetAtomKey(description, 0)->value; 2163 2164 return (alist); 2165} 2166 2167void 2168LispAddBuiltinFunction(LispBuiltin *builtin) 2169{ 2170 static LispObj stream; 2171 static LispString string; 2172 static int first = 1; 2173 LispObj *name, *obj, *list, *cons, *code; 2174 LispAtom *atom; 2175 LispArgList *alist; 2176 int length = lisp__data.protect.length; 2177 2178 if (first) { 2179 stream.type = LispStream_t; 2180 stream.data.stream.source.string = &string; 2181 stream.data.stream.pathname = NIL; 2182 stream.data.stream.type = LispStreamString; 2183 stream.data.stream.readable = 1; 2184 stream.data.stream.writable = 0; 2185 string.output = 0; 2186 first = 0; 2187 } 2188 string.string = builtin->declaration; 2189 string.length = strlen(builtin->declaration); 2190 string.input = 0; 2191 2192 code = COD; 2193 LispPushInput(&stream); 2194 name = LispRead(); 2195 list = cons = CONS(name, NIL); 2196 if (length + 1 >= lisp__data.protect.space) 2197 LispMoreProtects(); 2198 lisp__data.protect.objects[lisp__data.protect.length++] = list; 2199 while ((obj = LispRead()) != NULL) { 2200 RPLACD(cons, CONS(obj, NIL)); 2201 cons = CDR(cons); 2202 } 2203 LispPopInput(&stream); 2204 2205 atom = name->data.atom; 2206 alist = LispCheckArguments(builtin->type, CDR(list), atom->key->value, 1); 2207 builtin->symbol = CAR(list); 2208 LispSetAtomBuiltinProperty(atom, builtin, alist); 2209 LispUseArgList(alist); 2210 2211 /* Make function a extern symbol, unless told to not do so */ 2212 if (!builtin->internal) 2213 LispExportSymbol(name); 2214 2215 lisp__data.protect.length = length; 2216 COD = code; /* LispRead protect data in COD */ 2217} 2218 2219void 2220LispAllocSeg(LispObjSeg *seg, int cellcount) 2221{ 2222 unsigned int i; 2223 LispObj **list, *obj; 2224 2225 DISABLE_INTERRUPTS(); 2226 while (seg->nfree < cellcount) { 2227 if ((obj = (LispObj*)calloc(1, sizeof(LispObj) * segsize)) == NULL) { 2228 ENABLE_INTERRUPTS(); 2229 LispDestroy("out of memory"); 2230 } 2231 if ((list = (LispObj**)realloc(seg->objects, 2232 sizeof(LispObj*) * (seg->nsegs + 1))) == NULL) { 2233 free(obj); 2234 ENABLE_INTERRUPTS(); 2235 LispDestroy("out of memory"); 2236 } 2237 seg->objects = list; 2238 seg->objects[seg->nsegs] = obj; 2239 2240 seg->nfree += segsize; 2241 seg->nobjs += segsize; 2242 for (i = 1; i < segsize; i++, obj++) { 2243 /* Objects of type cons are the most used, save some time 2244 * by not setting it's type in LispNewCons. */ 2245 obj->type = LispCons_t; 2246 CDR(obj) = obj + 1; 2247 } 2248 obj->type = LispCons_t; 2249 CDR(obj) = seg->freeobj; 2250 seg->freeobj = seg->objects[seg->nsegs]; 2251 ++seg->nsegs; 2252 } 2253#ifdef DEBUG 2254 LispMessage("gc: %d cell(s) allocated at %d segment(s)", 2255 seg->nobjs, seg->nsegs); 2256#endif 2257 ENABLE_INTERRUPTS(); 2258} 2259 2260static INLINE void 2261LispMark(register LispObj *object) 2262{ 2263mark_again: 2264 switch (OBJECT_TYPE(object)) { 2265 case LispNil_t: 2266 case LispAtom_t: 2267 case LispFixnum_t: 2268 case LispSChar_t: 2269 case LispFunction_t: 2270 return; 2271 case LispLambda_t: 2272 if (OPAQUEP(object->data.lambda.name)) 2273 object->data.lambda.name->mark = 1; 2274 object->mark = 1; 2275 LispMark(object->data.lambda.data); 2276 object = object->data.lambda.code; 2277 goto mark_cons; 2278 case LispQuote_t: 2279 case LispBackquote_t: 2280 case LispFunctionQuote_t: 2281 object->mark = 1; 2282 object = object->data.quote; 2283 goto mark_again; 2284 case LispPathname_t: 2285 object->mark = 1; 2286 object = object->data.pathname; 2287 goto mark_again; 2288 case LispComma_t: 2289 object->mark = 1; 2290 object = object->data.comma.eval; 2291 goto mark_again; 2292 case LispComplex_t: 2293 if (POINTERP(object->data.complex.real)) 2294 object->data.complex.real->mark = 1; 2295 if (POINTERP(object->data.complex.imag)) 2296 object->data.complex.imag->mark = 1; 2297 break; 2298 case LispCons_t: 2299mark_cons: 2300 for (; CONSP(object) && !object->mark; object = CDR(object)) { 2301 object->mark = 1; 2302 switch (OBJECT_TYPE(CAR(object))) { 2303 case LispNil_t: 2304 case LispAtom_t: 2305 case LispFixnum_t: 2306 case LispSChar_t: 2307 case LispPackage_t: /* protected in gc */ 2308 break; 2309 case LispInteger_t: 2310 case LispDFloat_t: 2311 case LispString_t: 2312 case LispRatio_t: 2313 case LispOpaque_t: 2314 case LispBignum_t: 2315 case LispBigratio_t: 2316 CAR(object)->mark = 1; 2317 break; 2318 default: 2319 LispMark(CAR(object)); 2320 break; 2321 } 2322 } 2323 if (POINTERP(object) && !object->mark) 2324 goto mark_again; 2325 return; 2326 case LispArray_t: 2327 LispMark(object->data.array.list); 2328 object->mark = 1; 2329 object = object->data.array.dim; 2330 goto mark_cons; 2331 case LispStruct_t: 2332 object->mark = 1; 2333 object = object->data.struc.fields; 2334 goto mark_cons; 2335 case LispStream_t: 2336mark_stream: 2337 LispMark(object->data.stream.pathname); 2338 if (object->data.stream.type == LispStreamPipe) { 2339 object->mark = 1; 2340 object = object->data.stream.source.program->errorp; 2341 goto mark_stream; 2342 } 2343 break; 2344 case LispRegex_t: 2345 object->data.regex.pattern->mark = 1; 2346 break; 2347 case LispBytecode_t: 2348 object->mark = 1; 2349 object = object->data.bytecode.code; 2350 goto mark_again; 2351 case LispHashTable_t: { 2352 unsigned long i; 2353 LispHashEntry *entry = object->data.hash.table->entries, 2354 *last = entry + object->data.hash.table->num_entries; 2355 2356 if (object->mark) 2357 return; 2358 object->mark = 1; 2359 for (; entry < last; entry++) { 2360 for (i = 0; i < entry->count; i++) { 2361 switch (OBJECT_TYPE(entry->keys[i])) { 2362 case LispNil_t: 2363 case LispAtom_t: 2364 case LispFixnum_t: 2365 case LispSChar_t: 2366 case LispFunction_t: 2367 case LispPackage_t: 2368 break; 2369 case LispInteger_t: 2370 case LispDFloat_t: 2371 case LispString_t: 2372 case LispRatio_t: 2373 case LispOpaque_t: 2374 case LispBignum_t: 2375 case LispBigratio_t: 2376 entry->keys[i]->mark = 1; 2377 break; 2378 default: 2379 LispMark(entry->keys[i]); 2380 break; 2381 } 2382 switch (OBJECT_TYPE(entry->values[i])) { 2383 case LispNil_t: 2384 case LispAtom_t: 2385 case LispFixnum_t: 2386 case LispSChar_t: 2387 case LispFunction_t: 2388 case LispPackage_t: 2389 break; 2390 case LispInteger_t: 2391 case LispDFloat_t: 2392 case LispString_t: 2393 case LispRatio_t: 2394 case LispOpaque_t: 2395 case LispBignum_t: 2396 case LispBigratio_t: 2397 entry->values[i]->mark = 1; 2398 break; 2399 default: 2400 LispMark(entry->values[i]); 2401 break; 2402 } 2403 } 2404 } 2405 } return; 2406 default: 2407 break; 2408 } 2409 object->mark = 1; 2410} 2411 2412static INLINE void 2413LispProt(register LispObj *object) 2414{ 2415prot_again: 2416 switch (OBJECT_TYPE(object)) { 2417 case LispNil_t: 2418 case LispAtom_t: 2419 case LispFixnum_t: 2420 case LispSChar_t: 2421 case LispFunction_t: 2422 return; 2423 case LispLambda_t: 2424 if (OPAQUEP(object->data.lambda.name)) 2425 object->data.lambda.name->prot = 1; 2426 object->prot = 1; 2427 LispProt(object->data.lambda.data); 2428 object = object->data.lambda.code; 2429 goto prot_cons; 2430 case LispQuote_t: 2431 case LispBackquote_t: 2432 case LispFunctionQuote_t: 2433 object->prot = 1; 2434 object = object->data.quote; 2435 goto prot_again; 2436 case LispPathname_t: 2437 object->prot = 1; 2438 object = object->data.pathname; 2439 goto prot_again; 2440 case LispComma_t: 2441 object->prot = 1; 2442 object = object->data.comma.eval; 2443 goto prot_again; 2444 case LispComplex_t: 2445 if (POINTERP(object->data.complex.real)) 2446 object->data.complex.real->prot = 1; 2447 if (POINTERP(object->data.complex.imag)) 2448 object->data.complex.imag->prot = 1; 2449 break; 2450 case LispCons_t: 2451prot_cons: 2452 for (; CONSP(object) && !object->prot; object = CDR(object)) { 2453 object->prot = 1; 2454 switch (OBJECT_TYPE(CAR(object))) { 2455 case LispNil_t: 2456 case LispAtom_t: 2457 case LispFixnum_t: 2458 case LispSChar_t: 2459 case LispFunction_t: 2460 case LispPackage_t: /* protected in gc */ 2461 break; 2462 case LispInteger_t: 2463 case LispDFloat_t: 2464 case LispString_t: 2465 case LispRatio_t: 2466 case LispOpaque_t: 2467 case LispBignum_t: 2468 case LispBigratio_t: 2469 CAR(object)->prot = 1; 2470 break; 2471 default: 2472 LispProt(CAR(object)); 2473 break; 2474 } 2475 } 2476 if (POINTERP(object) && !object->prot) 2477 goto prot_again; 2478 return; 2479 case LispArray_t: 2480 LispProt(object->data.array.list); 2481 object->prot = 1; 2482 object = object->data.array.dim; 2483 goto prot_cons; 2484 case LispStruct_t: 2485 object->prot = 1; 2486 object = object->data.struc.fields; 2487 goto prot_cons; 2488 case LispStream_t: 2489prot_stream: 2490 LispProt(object->data.stream.pathname); 2491 if (object->data.stream.type == LispStreamPipe) { 2492 object->prot = 1; 2493 object = object->data.stream.source.program->errorp; 2494 goto prot_stream; 2495 } 2496 break; 2497 case LispRegex_t: 2498 object->data.regex.pattern->prot = 1; 2499 break; 2500 case LispBytecode_t: 2501 object->prot = 1; 2502 object = object->data.bytecode.code; 2503 goto prot_again; 2504 case LispHashTable_t: { 2505 unsigned long i; 2506 LispHashEntry *entry = object->data.hash.table->entries, 2507 *last = entry + object->data.hash.table->num_entries; 2508 2509 if (object->prot) 2510 return; 2511 object->prot = 1; 2512 for (; entry < last; entry++) { 2513 for (i = 0; i < entry->count; i++) { 2514 switch (OBJECT_TYPE(entry->keys[i])) { 2515 case LispNil_t: 2516 case LispAtom_t: 2517 case LispFixnum_t: 2518 case LispSChar_t: 2519 case LispFunction_t: 2520 case LispPackage_t: 2521 break; 2522 case LispInteger_t: 2523 case LispDFloat_t: 2524 case LispString_t: 2525 case LispRatio_t: 2526 case LispOpaque_t: 2527 case LispBignum_t: 2528 case LispBigratio_t: 2529 entry->keys[i]->prot = 1; 2530 break; 2531 default: 2532 LispProt(entry->keys[i]); 2533 break; 2534 } 2535 switch (OBJECT_TYPE(entry->values[i])) { 2536 case LispNil_t: 2537 case LispAtom_t: 2538 case LispFixnum_t: 2539 case LispSChar_t: 2540 case LispFunction_t: 2541 case LispPackage_t: 2542 break; 2543 case LispInteger_t: 2544 case LispDFloat_t: 2545 case LispString_t: 2546 case LispRatio_t: 2547 case LispOpaque_t: 2548 case LispBignum_t: 2549 case LispBigratio_t: 2550 entry->values[i]->prot = 1; 2551 break; 2552 default: 2553 LispProt(entry->values[i]); 2554 break; 2555 } 2556 } 2557 } 2558 } return; 2559 default: 2560 break; 2561 } 2562 object->prot = 1; 2563} 2564 2565void 2566LispProtect(LispObj *key, LispObj *list) 2567{ 2568 PRO = CONS(CONS(key, list), PRO); 2569} 2570 2571void 2572LispUProtect(LispObj *key, LispObj *list) 2573{ 2574 LispObj *prev, *obj; 2575 2576 for (prev = obj = PRO; obj != NIL; prev = obj, obj = CDR(obj)) 2577 if (CAR(CAR(obj)) == key && CDR(CAR(obj)) == list) { 2578 if (obj == PRO) 2579 PRO = CDR(PRO); 2580 else 2581 CDR(prev) = CDR(obj); 2582 return; 2583 } 2584 2585 LispDestroy("no match for %s, at UPROTECT", STROBJ(key)); 2586} 2587 2588static LispObj * 2589Lisp__New(LispObj *car, LispObj *cdr) 2590{ 2591 int cellcount; 2592 LispObj *obj; 2593 2594 Lisp__GC(car, cdr); 2595#if 0 2596 lisp__data.gc.average = (objseg.nfree + lisp__data.gc.average) >> 1; 2597 if (lisp__data.gc.average < minfree) { 2598 if (lisp__data.gc.expandbits < 6) 2599 ++lisp__data.gc.expandbits; 2600 } 2601 else if (lisp__data.gc.expandbits) 2602 --lisp__data.gc.expandbits; 2603 /* For 32 bit computers, where sizeof(LispObj) == 16, 2604 * minfree is set to 1024, and expandbits limited to 6, 2605 * the maximum extra memory requested here should be 1Mb 2606 */ 2607 cellcount = minfree << lisp__data.gc.expandbits; 2608#else 2609 /* Try to keep at least 3 times more free cells than the de number 2610 * of used cells in the freelist, to amenize the cost of the gc time, 2611 * in the, currently, very simple gc strategy code. */ 2612 cellcount = (objseg.nobjs - objseg.nfree) * 3; 2613 cellcount = cellcount + (minfree - (cellcount % minfree)); 2614#endif 2615 2616 if (objseg.freeobj == NIL || objseg.nfree < cellcount) 2617 LispAllocSeg(&objseg, cellcount); 2618 2619 obj = objseg.freeobj; 2620 objseg.freeobj = CDR(obj); 2621 --objseg.nfree; 2622 2623 return (obj); 2624} 2625 2626LispObj * 2627LispNew(LispObj *car, LispObj *cdr) 2628{ 2629 LispObj *obj = objseg.freeobj; 2630 2631 if (obj == NIL) 2632 obj = Lisp__New(car, cdr); 2633 else { 2634 objseg.freeobj = CDR(obj); 2635 --objseg.nfree; 2636 } 2637 2638 return (obj); 2639} 2640 2641LispObj * 2642LispNewAtom(char *str, int intern) 2643{ 2644 LispObj *object; 2645 LispAtom *atom = LispDoGetAtom(str, 0); 2646 2647 if (atom->object) { 2648 if (intern && atom->package == NULL) 2649 atom->package = PACKAGE; 2650 2651 return (atom->object); 2652 } 2653 2654 if (atomseg.freeobj == NIL) 2655 LispAllocSeg(&atomseg, pagesize); 2656 object = atomseg.freeobj; 2657 atomseg.freeobj = CDR(object); 2658 --atomseg.nfree; 2659 2660 object->type = LispAtom_t; 2661 object->data.atom = atom; 2662 atom->object = object; 2663 if (intern) 2664 atom->package = PACKAGE; 2665 2666 return (object); 2667} 2668 2669LispObj * 2670LispNewStaticAtom(char *str) 2671{ 2672 LispObj *object; 2673 LispAtom *atom = LispDoGetAtom(str, 1); 2674 2675 object = LispNewSymbol(atom); 2676 2677 return (object); 2678} 2679 2680LispObj * 2681LispNewSymbol(LispAtom *atom) 2682{ 2683 if (atom->object) { 2684 if (atom->package == NULL) 2685 atom->package = PACKAGE; 2686 2687 return (atom->object); 2688 } 2689 else { 2690 LispObj *symbol; 2691 2692 if (atomseg.freeobj == NIL) 2693 LispAllocSeg(&atomseg, pagesize); 2694 symbol = atomseg.freeobj; 2695 atomseg.freeobj = CDR(symbol); 2696 --atomseg.nfree; 2697 2698 symbol->type = LispAtom_t; 2699 symbol->data.atom = atom; 2700 atom->object = symbol; 2701 atom->package = PACKAGE; 2702 2703 return (symbol); 2704 } 2705} 2706 2707/* function representation is created on demand and never released, 2708 * even if the function is undefined and never defined again */ 2709LispObj * 2710LispNewFunction(LispObj *symbol) 2711{ 2712 LispObj *function; 2713 2714 if (symbol->data.atom->function) 2715 return (symbol->data.atom->function); 2716 2717 if (symbol->data.atom->package == NULL) 2718 symbol->data.atom->package = PACKAGE; 2719 2720 if (atomseg.freeobj == NIL) 2721 LispAllocSeg(&atomseg, pagesize); 2722 function = atomseg.freeobj; 2723 atomseg.freeobj = CDR(function); 2724 --atomseg.nfree; 2725 2726 function->type = LispFunction_t; 2727 function->data.atom = symbol->data.atom; 2728 symbol->data.atom->function = function; 2729 2730 return (function); 2731} 2732 2733/* symbol name representation is created on demand and never released */ 2734LispObj * 2735LispSymbolName(LispObj *symbol) 2736{ 2737 LispObj *name; 2738 LispAtom *atom = symbol->data.atom; 2739 2740 if (atom->name) 2741 return (atom->name); 2742 2743 if (atomseg.freeobj == NIL) 2744 LispAllocSeg(&atomseg, pagesize); 2745 name = atomseg.freeobj; 2746 atomseg.freeobj = CDR(name); 2747 --atomseg.nfree; 2748 2749 name->type = LispString_t; 2750 THESTR(name) = atom->key->value; 2751 STRLEN(name) = atom->key->length; 2752 name->data.string.writable = 0; 2753 atom->name = name; 2754 2755 return (name); 2756} 2757 2758LispObj * 2759LispNewFunctionQuote(LispObj *object) 2760{ 2761 LispObj *quote = LispNew(object, NIL); 2762 2763 quote->type = LispFunctionQuote_t; 2764 quote->data.quote = object; 2765 2766 return (quote); 2767} 2768 2769LispObj * 2770LispNewDFloat(double value) 2771{ 2772 LispObj *dfloat = objseg.freeobj; 2773 2774 if (dfloat == NIL) 2775 dfloat = Lisp__New(NIL, NIL); 2776 else { 2777 objseg.freeobj = CDR(dfloat); 2778 --objseg.nfree; 2779 } 2780 dfloat->type = LispDFloat_t; 2781 dfloat->data.dfloat = value; 2782 2783 return (dfloat); 2784} 2785 2786LispObj * 2787LispNewString(char *str, long length, int alloced) 2788{ 2789 char *cstring; 2790 LispObj *string = objseg.freeobj; 2791 2792 if (string == NIL) 2793 string = Lisp__New(NIL, NIL); 2794 else { 2795 objseg.freeobj = CDR(string); 2796 --objseg.nfree; 2797 } 2798 if (alloced) 2799 cstring = str; 2800 else { 2801 cstring = LispMalloc(length + 1); 2802 memcpy(cstring, str, length); 2803 cstring[length] = '\0'; 2804 } 2805 LispMused(cstring); 2806 string->type = LispString_t; 2807 THESTR(string) = cstring; 2808 STRLEN(string) = length; 2809 string->data.string.writable = 1; 2810 2811 return (string); 2812} 2813 2814LispObj * 2815LispNewComplex(LispObj *realpart, LispObj *imagpart) 2816{ 2817 LispObj *complexp = objseg.freeobj; 2818 2819 if (complexp == NIL) 2820 complexp = Lisp__New(realpart, imagpart); 2821 else { 2822 objseg.freeobj = CDR(complexp); 2823 --objseg.nfree; 2824 } 2825 complexp->type = LispComplex_t; 2826 complexp->data.complex.real = realpart; 2827 complexp->data.complex.imag = imagpart; 2828 2829 return (complexp); 2830} 2831 2832LispObj * 2833LispNewInteger(long integer) 2834{ 2835 if (integer > MOST_POSITIVE_FIXNUM || integer < MOST_NEGATIVE_FIXNUM) { 2836 LispObj *object = objseg.freeobj; 2837 2838 if (object == NIL) 2839 object = Lisp__New(NIL, NIL); 2840 else { 2841 objseg.freeobj = CDR(object); 2842 --objseg.nfree; 2843 } 2844 object->type = LispInteger_t; 2845 object->data.integer = integer; 2846 2847 return (object); 2848 } 2849 return (FIXNUM(integer)); 2850} 2851 2852LispObj * 2853LispNewRatio(long num, long den) 2854{ 2855 LispObj *ratio = objseg.freeobj; 2856 2857 if (ratio == NIL) 2858 ratio = Lisp__New(NIL, NIL); 2859 else { 2860 objseg.freeobj = CDR(ratio); 2861 --objseg.nfree; 2862 } 2863 ratio->type = LispRatio_t; 2864 ratio->data.ratio.numerator = num; 2865 ratio->data.ratio.denominator = den; 2866 2867 return (ratio); 2868} 2869 2870LispObj * 2871LispNewVector(LispObj *objects) 2872{ 2873 GC_ENTER(); 2874 long count; 2875 LispObj *array, *dimension; 2876 2877 for (count = 0, array = objects; CONSP(array); count++, array = CDR(array)) 2878 ; 2879 2880 GC_PROTECT(objects); 2881 dimension = CONS(FIXNUM(count), NIL); 2882 array = LispNew(objects, dimension); 2883 array->type = LispArray_t; 2884 array->data.array.list = objects; 2885 array->data.array.dim = dimension; 2886 array->data.array.rank = 1; 2887 array->data.array.type = LispNil_t; 2888 array->data.array.zero = count == 0; 2889 GC_LEAVE(); 2890 2891 return (array); 2892} 2893 2894LispObj * 2895LispNewQuote(LispObj *object) 2896{ 2897 LispObj *quote = LispNew(object, NIL); 2898 2899 quote->type = LispQuote_t; 2900 quote->data.quote = object; 2901 2902 return (quote); 2903} 2904 2905LispObj * 2906LispNewBackquote(LispObj *object) 2907{ 2908 LispObj *backquote = LispNew(object, NIL); 2909 2910 backquote->type = LispBackquote_t; 2911 backquote->data.quote = object; 2912 2913 return (backquote); 2914} 2915 2916LispObj * 2917LispNewComma(LispObj *object, int atlist) 2918{ 2919 LispObj *comma = LispNew(object, NIL); 2920 2921 comma->type = LispComma_t; 2922 comma->data.comma.eval = object; 2923 comma->data.comma.atlist = atlist; 2924 2925 return (comma); 2926} 2927 2928LispObj * 2929LispNewCons(LispObj *car, LispObj *cdr) 2930{ 2931 LispObj *cons = objseg.freeobj; 2932 2933 if (cons == NIL) 2934 cons = Lisp__New(car, cdr); 2935 else { 2936 objseg.freeobj = CDR(cons); 2937 --objseg.nfree; 2938 } 2939 CAR(cons) = car; 2940 CDR(cons) = cdr; 2941 2942 return (cons); 2943} 2944 2945LispObj * 2946LispNewLambda(LispObj *name, LispObj *code, LispObj *data, LispFunType type) 2947{ 2948 LispObj *fun = LispNew(data, code); 2949 2950 fun->type = LispLambda_t; 2951 fun->funtype = type; 2952 fun->data.lambda.name = name; 2953 fun->data.lambda.code = code; 2954 fun->data.lambda.data = data; 2955 2956 return (fun); 2957} 2958 2959LispObj * 2960LispNewStruct(LispObj *fields, LispObj *def) 2961{ 2962 LispObj *struc = LispNew(fields, def); 2963 2964 struc->type = LispStruct_t; 2965 struc->data.struc.fields = fields; 2966 struc->data.struc.def = def; 2967 2968 return (struc); 2969} 2970 2971LispObj * 2972LispNewOpaque(void *data, int type) 2973{ 2974 LispObj *opaque = LispNew(NIL, NIL); 2975 2976 opaque->type = LispOpaque_t; 2977 opaque->data.opaque.data = data; 2978 opaque->data.opaque.type = type; 2979 2980 return (opaque); 2981} 2982 2983/* string argument must be static, or allocated */ 2984LispObj * 2985LispNewKeyword(char *string) 2986{ 2987 LispObj *keyword; 2988 2989 if (PACKAGE != lisp__data.keyword) { 2990 LispObj *savepackage; 2991 LispPackage *savepack; 2992 2993 /* Save package environment */ 2994 savepackage = PACKAGE; 2995 savepack = lisp__data.pack; 2996 2997 /* Change package environment */ 2998 PACKAGE = lisp__data.keyword; 2999 lisp__data.pack = lisp__data.key; 3000 3001 /* Create symbol in keyword package */ 3002 keyword = LispNewStaticAtom(string); 3003 3004 /* Restore package environment */ 3005 PACKAGE = savepackage; 3006 lisp__data.pack = savepack; 3007 } 3008 else 3009 /* Just create symbol in keyword package */ 3010 keyword = LispNewStaticAtom(string); 3011 3012 /* Export keyword symbol */ 3013 LispExportSymbol(keyword); 3014 3015 /* All keywords are constants */ 3016 keyword->data.atom->constant = 1; 3017 3018 /* XXX maybe should bound the keyword to itself, but that would 3019 * require allocating a LispProperty structure for every keyword */ 3020 3021 return (keyword); 3022} 3023 3024LispObj * 3025LispNewPathname(LispObj *obj) 3026{ 3027 LispObj *path = LispNew(obj, NIL); 3028 3029 path->type = LispPathname_t; 3030 path->data.pathname = obj; 3031 3032 return (path); 3033} 3034 3035LispObj * 3036LispNewStringStream(char *string, int flags, long length, int alloced) 3037{ 3038 LispObj *stream = LispNew(NIL, NIL); 3039 3040 SSTREAMP(stream) = LispCalloc(1, sizeof(LispString)); 3041 if (alloced) 3042 SSTREAMP(stream)->string = string; 3043 else { 3044 SSTREAMP(stream)->string = LispMalloc(length + 1); 3045 memcpy(SSTREAMP(stream)->string, string, length); 3046 SSTREAMP(stream)->string[length] = '\0'; 3047 } 3048 3049 stream->type = LispStream_t; 3050 3051 SSTREAMP(stream)->length = length; 3052 LispMused(SSTREAMP(stream)); 3053 LispMused(SSTREAMP(stream)->string); 3054 stream->data.stream.type = LispStreamString; 3055 stream->data.stream.readable = (flags & STREAM_READ) != 0; 3056 stream->data.stream.writable = (flags & STREAM_WRITE) != 0; 3057 SSTREAMP(stream)->space = length + 1; 3058 3059 stream->data.stream.pathname = NIL; 3060 3061 return (stream); 3062} 3063 3064LispObj * 3065LispNewFileStream(LispFile *file, LispObj *path, int flags) 3066{ 3067 LispObj *stream = LispNew(NIL, NIL); 3068 3069 stream->type = LispStream_t; 3070 FSTREAMP(stream) = file; 3071 stream->data.stream.pathname = path; 3072 stream->data.stream.type = LispStreamFile; 3073 stream->data.stream.readable = (flags & STREAM_READ) != 0; 3074 stream->data.stream.writable = (flags & STREAM_WRITE) != 0; 3075 3076 return (stream); 3077} 3078 3079LispObj * 3080LispNewPipeStream(LispPipe *program, LispObj *path, int flags) 3081{ 3082 LispObj *stream = LispNew(NIL, NIL); 3083 3084 stream->type = LispStream_t; 3085 PSTREAMP(stream) = program; 3086 stream->data.stream.pathname = path; 3087 stream->data.stream.type = LispStreamPipe; 3088 stream->data.stream.readable = (flags & STREAM_READ) != 0; 3089 stream->data.stream.writable = (flags & STREAM_WRITE) != 0; 3090 3091 return (stream); 3092} 3093 3094LispObj * 3095LispNewStandardStream(LispFile *file, LispObj *description, int flags) 3096{ 3097 LispObj *stream = LispNew(NIL, NIL); 3098 3099 stream->type = LispStream_t; 3100 FSTREAMP(stream) = file; 3101 stream->data.stream.pathname = description; 3102 stream->data.stream.type = LispStreamStandard; 3103 stream->data.stream.readable = (flags & STREAM_READ) != 0; 3104 stream->data.stream.writable = (flags & STREAM_WRITE) != 0; 3105 3106 return (stream); 3107} 3108 3109LispObj * 3110LispNewBignum(mpi *bignum) 3111{ 3112 LispObj *integer = LispNew(NIL, NIL); 3113 3114 integer->type = LispBignum_t; 3115 integer->data.mp.integer = bignum; 3116 LispMused(bignum->digs); 3117 LispMused(bignum); 3118 3119 return (integer); 3120} 3121 3122LispObj * 3123LispNewBigratio(mpr *bigratio) 3124{ 3125 LispObj *ratio = LispNew(NIL, NIL); 3126 3127 ratio->type = LispBigratio_t; 3128 ratio->data.mp.ratio = bigratio; 3129 LispMused(mpr_num(bigratio)->digs); 3130 LispMused(mpr_den(bigratio)->digs); 3131 LispMused(bigratio); 3132 3133 return (ratio); 3134} 3135 3136/* name must be of type LispString_t */ 3137LispObj * 3138LispNewPackage(LispObj *name, LispObj *nicknames) 3139{ 3140 LispObj *package = LispNew(name, nicknames); 3141 LispPackage *pack = LispCalloc(1, sizeof(LispPackage)); 3142 3143 package->type = LispPackage_t; 3144 package->data.package.name = name; 3145 package->data.package.nicknames = nicknames; 3146 package->data.package.package = pack; 3147 3148 package->data.package.package->atoms = hash_new(STRTBLSZ, NULL); 3149 3150 LispMused(pack); 3151 3152 return (package); 3153} 3154 3155LispObj * 3156LispSymbolFunction(LispObj *symbol) 3157{ 3158 LispAtom *atom = symbol->data.atom; 3159 3160 if ((atom->a_builtin && 3161 atom->property->fun.builtin->type == LispFunction) || 3162 (atom->a_function && 3163 atom->property->fun.function->funtype == LispFunction) || 3164 (atom->a_defstruct && 3165 atom->property->structure.function != STRUCT_NAME) || 3166 /* XXX currently bytecode is only generated for functions */ 3167 atom->a_compiled) 3168 symbol = FUNCTION(symbol); 3169 else 3170 LispDestroy("SYMBOL-FUNCTION: %s is not a function", STROBJ(symbol)); 3171 3172 return (symbol); 3173} 3174 3175 3176static INLINE LispObj * 3177LispGetVarPack(LispObj *symbol) 3178{ 3179 LispAtom *atom; 3180 3181 atom = (LispAtom *)hash_get(lisp__data.pack->atoms, 3182 symbol->data.atom->key); 3183 3184 return (atom ? atom->object : NULL); 3185} 3186 3187/* package must be of type LispPackage_t */ 3188void 3189LispUsePackage(LispObj *package) 3190{ 3191 LispAtom *atom; 3192 LispPackage *pack; 3193 LispObj **pentry, **eentry; 3194 3195 /* Already using its own symbols... */ 3196 if (package == PACKAGE) 3197 return; 3198 3199 /* Check if package not already in use-package list */ 3200 for (pentry = lisp__data.pack->use.pairs, 3201 eentry = pentry + lisp__data.pack->use.length; 3202 pentry < eentry; pentry++) 3203 if (*pentry == package) 3204 return; 3205 3206 /* Remember this package is in the use-package list */ 3207 if (lisp__data.pack->use.length + 1 >= lisp__data.pack->use.space) { 3208 LispObj **pairs = realloc(lisp__data.pack->use.pairs, 3209 (lisp__data.pack->use.space + 1) * 3210 sizeof(LispObj*)); 3211 3212 if (pairs == NULL) 3213 LispDestroy("out of memory"); 3214 3215 lisp__data.pack->use.pairs = pairs; 3216 ++lisp__data.pack->use.space; 3217 } 3218 lisp__data.pack->use.pairs[lisp__data.pack->use.length++] = package; 3219 3220 /* Import all extern symbols from package */ 3221 pack = package->data.package.package; 3222 3223 /* Traverse atom list, searching for extern symbols */ 3224 for (atom = (LispAtom *)hash_iter_first(pack->atoms); 3225 atom; 3226 atom = (LispAtom *)hash_iter_next(pack->atoms)) { 3227 if (atom->ext) 3228 LispImportSymbol(atom->object); 3229 } 3230} 3231 3232/* symbol must be of type LispAtom_t */ 3233void 3234LispImportSymbol(LispObj *symbol) 3235{ 3236 int increment; 3237 LispAtom *atom; 3238 LispObj *current; 3239 3240 current = LispGetVarPack(symbol); 3241 if (current == NULL || current->data.atom->property == NOPROPERTY) { 3242 /* No conflicts */ 3243 3244 if (symbol->data.atom->a_object) { 3245 /* If it is a bounded variable */ 3246 if (lisp__data.pack->glb.length + 1 >= lisp__data.pack->glb.space) 3247 LispMoreGlobals(lisp__data.pack); 3248 lisp__data.pack->glb.pairs[lisp__data.pack->glb.length++] = symbol; 3249 } 3250 3251 /* Create copy of atom in current package */ 3252 atom = LispDoGetAtom(ATOMID(symbol)->value, 0); 3253 /* Need to create a copy because if anything new is atached to the 3254 * property, the current package is the owner, not the previous one. */ 3255 3256 /* And reference the same properties */ 3257 atom->property = symbol->data.atom->property; 3258 3259 increment = 1; 3260 } 3261 else if (current->data.atom->property != symbol->data.atom->property) { 3262 /* Symbol already exists in the current package, 3263 * but does not reference the same variable */ 3264 LispContinuable("Symbol %s already defined in package %s. Redefine?", 3265 ATOMID(symbol)->value, THESTR(PACKAGE->data.package.name)); 3266 3267 atom = current->data.atom; 3268 3269 /* Continued from error, redefine variable */ 3270 LispDecrementAtomReference(atom); 3271 atom->property = symbol->data.atom->property; 3272 3273 atom->a_object = atom->a_function = atom->a_builtin = 3274 atom->a_property = atom->a_defsetf = atom->a_defstruct = 0; 3275 3276 increment = 1; 3277 } 3278 else { 3279 /* Symbol is already available in the current package, just update */ 3280 atom = current->data.atom; 3281 3282 increment = 0; 3283 } 3284 3285 /* If importing an important system variable */ 3286 atom->watch = symbol->data.atom->watch; 3287 3288 /* Update constant flag */ 3289 atom->constant = symbol->data.atom->constant; 3290 3291 /* Set home-package and unique-atom associated with symbol */ 3292 atom->package = symbol->data.atom->package; 3293 atom->object = symbol->data.atom->object; 3294 3295 if (symbol->data.atom->a_object) 3296 atom->a_object = 1; 3297 if (symbol->data.atom->a_function) 3298 atom->a_function = 1; 3299 else if (symbol->data.atom->a_builtin) 3300 atom->a_builtin = 1; 3301 else if (symbol->data.atom->a_compiled) 3302 atom->a_compiled = 1; 3303 if (symbol->data.atom->a_property) 3304 atom->a_property = 1; 3305 if (symbol->data.atom->a_defsetf) 3306 atom->a_defsetf = 1; 3307 if (symbol->data.atom->a_defstruct) 3308 atom->a_defstruct = 1; 3309 3310 if (increment) 3311 /* Increase reference count, more than one package using the symbol */ 3312 LispIncrementAtomReference(symbol->data.atom); 3313} 3314 3315/* symbol must be of type LispAtom_t */ 3316void 3317LispExportSymbol(LispObj *symbol) 3318{ 3319 /* This does not automatically export symbols to another package using 3320 * the symbols of the current package */ 3321 symbol->data.atom->ext = 1; 3322} 3323 3324#ifdef __GNUC__ 3325LispObj * 3326LispGetVar(LispObj *atom) 3327{ 3328 return (LispDoGetVar(atom)); 3329} 3330 3331static INLINE LispObj * 3332LispDoGetVar(LispObj *atom) 3333#else 3334#define LispDoGetVar LispGetVar 3335LispObj * 3336LispGetVar(LispObj *atom) 3337#endif 3338{ 3339 LispAtom *name; 3340 int i, base, offset; 3341 Atom_id id; 3342 3343 name = atom->data.atom; 3344 if (name->constant && name->package == lisp__data.keyword) 3345 return (atom); 3346 3347 /* XXX offset should be stored elsewhere, it is unique, like the string 3348 * pointer. Unless a multi-thread interface is implemented (where 3349 * multiple stacks would be required, the offset value should be 3350 * stored with the string, so that a few cpu cicles could be saved 3351 * by initializing the value to -1, and only searching for the symbol 3352 * binding if it is not -1, and if no binding is found, because the 3353 * lexical scope was left, reset offset to -1. */ 3354 offset = name->offset; 3355 id = name->key; 3356 base = lisp__data.env.lex; 3357 i = lisp__data.env.head - 1; 3358 3359 if (offset <= i && (offset >= base || name->dyn) && 3360 lisp__data.env.names[offset] == id) 3361 return (lisp__data.env.values[offset]); 3362 3363 for (; i >= base; i--) 3364 if (lisp__data.env.names[i] == id) { 3365 name->offset = i; 3366 3367 return (lisp__data.env.values[i]); 3368 } 3369 3370 if (name->dyn) { 3371 /* Keep searching as maybe a rebound dynamic variable */ 3372 for (; i >= 0; i--) 3373 if (lisp__data.env.names[i] == id) { 3374 name->offset = i; 3375 3376 return (lisp__data.env.values[i]); 3377 } 3378 3379 if (name->a_object) { 3380 /* Check for a symbol defined as special, but not yet bound. */ 3381 if (name->property->value == UNBOUND) 3382 return (NULL); 3383 3384 return (name->property->value); 3385 } 3386 } 3387 3388 return (name->a_object ? name->property->value : NULL); 3389} 3390 3391#ifdef DEBUGGER 3392/* Same code as LispDoGetVar, but returns the address of the pointer to 3393 * the object value. Used only by the debugger */ 3394void * 3395LispGetVarAddr(LispObj *atom) 3396{ 3397 LispAtom *name; 3398 int i, base; 3399 Atom_id id; 3400 3401 name = atom->data.atom; 3402 if (name->constant && name->package == lisp__data.keyword) 3403 return (&atom); 3404 3405 id = name->string; 3406 3407 i = lisp__data.env.head - 1; 3408 for (base = lisp__data.env.lex; i >= base; i--) 3409 if (lisp__data.env.names[i] == id) 3410 return (&(lisp__data.env.values[i])); 3411 3412 if (name->dyn) { 3413 for (; i >= 0; i--) 3414 if (lisp__data.env.names[i] == id) 3415 return (&(lisp__data.env.values[i])); 3416 3417 if (name->a_object) { 3418 /* Check for a symbol defined as special, but not yet bound */ 3419 if (name->property->value == UNBOUND) 3420 return (NULL); 3421 3422 return (&(name->property->value)); 3423 } 3424 } 3425 3426 return (name->a_object ? &(name->property->value) : NULL); 3427} 3428#endif 3429 3430/* Only removes global variables. To be called by makunbound 3431 * Local variables are unbounded once their block is closed anyway. 3432 */ 3433void 3434LispUnsetVar(LispObj *atom) 3435{ 3436 LispAtom *name = atom->data.atom; 3437 3438 if (name->package) { 3439 int i; 3440 LispPackage *pack = name->package->data.package.package; 3441 3442 for (i = pack->glb.length - 1; i > 0; i--) 3443 if (pack->glb.pairs[i] == atom) { 3444 LispRemAtomObjectProperty(name); 3445 --pack->glb.length; 3446 if (i < pack->glb.length) 3447 memmove(pack->glb.pairs + i, pack->glb.pairs + i + 1, 3448 sizeof(LispObj*) * (pack->glb.length - i)); 3449 3450 /* unset hint about dynamically binded variable */ 3451 if (name->dyn) 3452 name->dyn = 0; 3453 break; 3454 } 3455 } 3456} 3457 3458LispObj * 3459LispAddVar(LispObj *atom, LispObj *obj) 3460{ 3461 if (lisp__data.env.length >= lisp__data.env.space) 3462 LispMoreEnvironment(); 3463 3464 LispDoAddVar(atom, obj); 3465 3466 return (obj); 3467} 3468 3469static INLINE void 3470LispDoAddVar(LispObj *symbol, LispObj *value) 3471{ 3472 LispAtom *atom = symbol->data.atom; 3473 3474 atom->offset = lisp__data.env.length; 3475 lisp__data.env.values[lisp__data.env.length] = value; 3476 lisp__data.env.names[lisp__data.env.length++] = atom->key; 3477} 3478 3479LispObj * 3480LispSetVar(LispObj *atom, LispObj *obj) 3481{ 3482 LispPackage *pack; 3483 LispAtom *name; 3484 int i, base, offset; 3485 Atom_id id; 3486 3487 name = atom->data.atom; 3488 offset = name->offset; 3489 id = name->key; 3490 base = lisp__data.env.lex; 3491 i = lisp__data.env.head - 1; 3492 3493 if (offset <= i && (offset >= base || name->dyn) && 3494 lisp__data.env.names[offset] == id) 3495 return (lisp__data.env.values[offset] = obj); 3496 3497 for (; i >= base; i--) 3498 if (lisp__data.env.names[i] == id) { 3499 name->offset = i; 3500 3501 return (lisp__data.env.values[i] = obj); 3502 } 3503 3504 if (name->dyn) { 3505 for (; i >= 0; i--) 3506 if (lisp__data.env.names[i] == id) 3507 return (lisp__data.env.values[i] = obj); 3508 3509 if (name->watch) { 3510 LispSetAtomObjectProperty(name, obj); 3511 3512 return (obj); 3513 } 3514 3515 return (SETVALUE(name, obj)); 3516 } 3517 3518 if (name->a_object) { 3519 if (name->watch) { 3520 LispSetAtomObjectProperty(name, obj); 3521 3522 return (obj); 3523 } 3524 3525 return (SETVALUE(name, obj)); 3526 } 3527 3528 LispSetAtomObjectProperty(name, obj); 3529 3530 pack = name->package->data.package.package; 3531 if (pack->glb.length >= pack->glb.space) 3532 LispMoreGlobals(pack); 3533 3534 pack->glb.pairs[pack->glb.length++] = atom; 3535 3536 return (obj); 3537} 3538 3539void 3540LispProclaimSpecial(LispObj *atom, LispObj *value, LispObj *doc) 3541{ 3542 int i = 0, dyn, glb; 3543 LispAtom *name; 3544 LispPackage *pack; 3545 3546 glb = 0; 3547 name = atom->data.atom; 3548 pack = name->package->data.package.package; 3549 dyn = name->dyn; 3550 3551 if (!dyn) { 3552 /* Note: don't check if a local variable already is using the symbol */ 3553 for (i = pack->glb.length - 1; i >= 0; i--) 3554 if (pack->glb.pairs[i] == atom) { 3555 glb = 1; 3556 break; 3557 } 3558 } 3559 3560 if (dyn) { 3561 if (name->property->value == UNBOUND && value) 3562 /* if variable was just made special, but not bounded */ 3563 LispSetAtomObjectProperty(name, value); 3564 } 3565 else if (glb) 3566 /* Already a global variable, but not marked as special. 3567 * Set hint about dynamically binded variable. */ 3568 name->dyn = 1; 3569 else { 3570 /* create new special variable */ 3571 LispSetAtomObjectProperty(name, value ? value : UNBOUND); 3572 3573 if (pack->glb.length >= pack->glb.space) 3574 LispMoreGlobals(pack); 3575 3576 pack->glb.pairs[pack->glb.length] = atom; 3577 ++pack->glb.length; 3578 /* set hint about possibly dynamically binded variable */ 3579 name->dyn = 1; 3580 } 3581 3582 if (doc != NIL) 3583 LispAddDocumentation(atom, doc, LispDocVariable); 3584} 3585 3586void 3587LispDefconstant(LispObj *atom, LispObj *value, LispObj *doc) 3588{ 3589 int i; 3590 LispAtom *name = atom->data.atom; 3591 LispPackage *pack = name->package->data.package.package; 3592 3593 /* Unset hint about dynamically binded variable, if set. */ 3594 name->dyn = 0; 3595 3596 /* Check if variable is bounded as a global variable */ 3597 for (i = pack->glb.length - 1; i >= 0; i--) 3598 if (pack->glb.pairs[i] == atom) 3599 break; 3600 3601 if (i < 0) { 3602 /* Not a global variable */ 3603 if (pack->glb.length >= pack->glb.space) 3604 LispMoreGlobals(pack); 3605 3606 pack->glb.pairs[pack->glb.length] = atom; 3607 ++pack->glb.length; 3608 } 3609 3610 /* If already a constant variable */ 3611 if (name->constant && name->a_object && name->property->value != value) 3612 LispWarning("constant %s is being redefined", STROBJ(atom)); 3613 else 3614 name->constant = 1; 3615 3616 /* Set constant value */ 3617 LispSetAtomObjectProperty(name, value); 3618 3619 if (doc != NIL) 3620 LispAddDocumentation(atom, doc, LispDocVariable); 3621} 3622 3623void 3624LispAddDocumentation(LispObj *symbol, LispObj *documentation, LispDocType_t type) 3625{ 3626 int length; 3627 char *string; 3628 LispAtom *atom; 3629 LispObj *object; 3630 3631 if (!SYMBOLP(symbol) || !STRINGP(documentation)) 3632 LispDestroy("DOCUMENTATION: invalid argument"); 3633 3634 atom = symbol->data.atom; 3635 if (atom->documentation[type]) 3636 LispRemDocumentation(symbol, type); 3637 3638 /* allocate documentation in atomseg */ 3639 if (atomseg.freeobj == NIL) 3640 LispAllocSeg(&atomseg, pagesize); 3641 length = STRLEN(documentation); 3642 string = LispMalloc(length); 3643 memcpy(string, THESTR(documentation), length); 3644 string[length] = '\0'; 3645 object = atomseg.freeobj; 3646 atomseg.freeobj = CDR(object); 3647 --atomseg.nfree; 3648 3649 object->type = LispString_t; 3650 THESTR(object) = string; 3651 STRLEN(object) = length; 3652 object->data.string.writable = 0; 3653 atom->documentation[type] = object; 3654 LispMused(string); 3655} 3656 3657void 3658LispRemDocumentation(LispObj *symbol, LispDocType_t type) 3659{ 3660 LispAtom *atom; 3661 3662 if (!SYMBOLP(symbol)) 3663 LispDestroy("DOCUMENTATION: invalid argument"); 3664 3665 atom = symbol->data.atom; 3666 if (atom->documentation[type]) { 3667 /* reclaim object to atomseg */ 3668 free(THESTR(atom->documentation[type])); 3669 CDR(atom->documentation[type]) = atomseg.freeobj; 3670 atomseg.freeobj = atom->documentation[type]; 3671 atom->documentation[type] = NULL; 3672 ++atomseg.nfree; 3673 } 3674} 3675 3676LispObj * 3677LispGetDocumentation(LispObj *symbol, LispDocType_t type) 3678{ 3679 LispAtom *atom; 3680 3681 if (!SYMBOLP(symbol)) 3682 LispDestroy("DOCUMENTATION: invalid argument"); 3683 3684 atom = symbol->data.atom; 3685 3686 return (atom->documentation[type] ? atom->documentation[type] : NIL); 3687} 3688 3689LispObj * 3690LispReverse(LispObj *list) 3691{ 3692 LispObj *tmp, *res = NIL; 3693 3694 while (list != NIL) { 3695 tmp = CDR(list); 3696 CDR(list) = res; 3697 res = list; 3698 list = tmp; 3699 } 3700 3701 return (res); 3702} 3703 3704LispBlock * 3705LispBeginBlock(LispObj *tag, LispBlockType type) 3706{ 3707 LispBlock *block; 3708 unsigned blevel = lisp__data.block.block_level + 1; 3709 3710 if (blevel > lisp__data.block.block_size) { 3711 LispBlock **blk; 3712 3713 if (blevel > MAX_STACK_DEPTH) 3714 LispDestroy("stack overflow"); 3715 3716 DISABLE_INTERRUPTS(); 3717 blk = realloc(lisp__data.block.block, sizeof(LispBlock*) * (blevel + 1)); 3718 3719 block = NULL; 3720 if (blk == NULL || (block = malloc(sizeof(LispBlock))) == NULL) { 3721 ENABLE_INTERRUPTS(); 3722 LispDestroy("out of memory"); 3723 } 3724 lisp__data.block.block = blk; 3725 lisp__data.block.block[lisp__data.block.block_size] = block; 3726 lisp__data.block.block_size = blevel; 3727 ENABLE_INTERRUPTS(); 3728 } 3729 block = lisp__data.block.block[lisp__data.block.block_level]; 3730 if (type == LispBlockCatch && !CONSTANTP(tag)) { 3731 tag = EVAL(tag); 3732 lisp__data.protect.objects[lisp__data.protect.length++] = tag; 3733 } 3734 block->type = type; 3735 block->tag = tag; 3736 block->stack = lisp__data.stack.length; 3737 block->protect = lisp__data.protect.length; 3738 block->block_level = lisp__data.block.block_level; 3739 3740 lisp__data.block.block_level = blevel; 3741 3742#ifdef DEBUGGER 3743 if (lisp__data.debugging) { 3744 block->debug_level = lisp__data.debug_level; 3745 block->debug_step = lisp__data.debug_step; 3746 } 3747#endif 3748 3749 return (block); 3750} 3751 3752void 3753LispEndBlock(LispBlock *block) 3754{ 3755 lisp__data.protect.length = block->protect; 3756 lisp__data.block.block_level = block->block_level; 3757 3758#ifdef DEBUGGER 3759 if (lisp__data.debugging) { 3760 if (lisp__data.debug_level >= block->debug_level) { 3761 while (lisp__data.debug_level > block->debug_level) { 3762 DBG = CDR(DBG); 3763 --lisp__data.debug_level; 3764 } 3765 } 3766 lisp__data.debug_step = block->debug_step; 3767 } 3768#endif 3769} 3770 3771void 3772LispBlockUnwind(LispBlock *block) 3773{ 3774 LispBlock *unwind; 3775 int blevel = lisp__data.block.block_level; 3776 3777 while (blevel > 0) { 3778 unwind = lisp__data.block.block[--blevel]; 3779 if (unwind->type == LispBlockProtect) { 3780 BLOCKJUMP(unwind); 3781 } 3782 if (unwind == block) 3783 /* jump above unwind block */ 3784 break; 3785 } 3786} 3787 3788static LispObj * 3789LispEvalBackquoteObject(LispObj *argument, int list, int quote) 3790{ 3791 LispObj *result = argument, *object; 3792 3793 if (!POINTERP(argument)) 3794 return (argument); 3795 3796 else if (XCOMMAP(argument)) { 3797 /* argument may need to be evaluated */ 3798 3799 int atlist; 3800 3801 if (!list && argument->data.comma.atlist) 3802 /* cannot append, not in a list */ 3803 LispDestroy("EVAL: ,@ only allowed on lists"); 3804 3805 --quote; 3806 if (quote < 0) 3807 LispDestroy("EVAL: comma outside of backquote"); 3808 3809 result = object = argument->data.comma.eval; 3810 atlist = COMMAP(object) && object->data.comma.atlist; 3811 3812 if (POINTERP(result) && (XCOMMAP(result) || XBACKQUOTEP(result))) 3813 /* nested commas, reduce 1 level, or backquote, 3814 * don't call LispEval or quote argument will be reset */ 3815 result = LispEvalBackquoteObject(object, 0, quote); 3816 3817 else if (quote == 0) 3818 /* just evaluate it */ 3819 result = EVAL(result); 3820 3821 if (quote != 0) 3822 result = result == object ? argument : COMMA(result, atlist); 3823 } 3824 3825 else if (XBACKQUOTEP(argument)) { 3826 object = argument->data.quote; 3827 3828 result = LispEvalBackquote(object, quote + 1); 3829 if (quote) 3830 result = result == object ? argument : BACKQUOTE(result); 3831 } 3832 3833 else if (XQUOTEP(argument) && POINTERP(argument->data.quote) && 3834 (XCOMMAP(argument->data.quote) || 3835 XBACKQUOTEP(argument->data.quote) || 3836 XCONSP(argument->data.quote))) { 3837 /* ensures `',sym to be the same as `(quote ,sym) */ 3838 object = argument->data.quote; 3839 3840 result = LispEvalBackquote(argument->data.quote, quote); 3841 result = result == object ? argument : QUOTE(result); 3842 } 3843 3844 return (result); 3845} 3846 3847LispObj * 3848LispEvalBackquote(LispObj *argument, int quote) 3849{ 3850 int protect; 3851 LispObj *result, *object, *cons, *cdr; 3852 3853 if (!CONSP(argument)) 3854 return (LispEvalBackquoteObject(argument, 0, quote)); 3855 3856 result = cdr = NIL; 3857 protect = lisp__data.protect.length; 3858 3859 /* always generate a new list for the result, even if nothing 3860 * is evaluated. It is not expected to use backqoutes when 3861 * not required. */ 3862 3863 /* reserve a GC protected slot for the result */ 3864 if (protect + 1 >= lisp__data.protect.space) 3865 LispMoreProtects(); 3866 lisp__data.protect.objects[lisp__data.protect.length++] = NIL; 3867 3868 for (cons = argument; ; cons = CDR(cons)) { 3869 /* if false, last argument, and if cons is not NIL, a dotted list */ 3870 int list = CONSP(cons), insert; 3871 3872 if (list) 3873 object = CAR(cons); 3874 else 3875 object = cons; 3876 3877 if (COMMAP(object)) 3878 /* need to insert list elements in result, not just cons it? */ 3879 insert = object->data.comma.atlist; 3880 else 3881 insert = 0; 3882 3883 /* evaluate object, if required */ 3884 if (CONSP(object)) 3885 object = LispEvalBackquote(object, quote); 3886 else 3887 object = LispEvalBackquoteObject(object, insert, quote); 3888 3889 if (result == NIL) { 3890 /* if starting result list */ 3891 if (!insert) { 3892 if (list) 3893 result = cdr = CONS(object, NIL); 3894 else 3895 result = cdr = object; 3896 /* gc protect result */ 3897 lisp__data.protect.objects[protect] = result; 3898 } 3899 else { 3900 if (!CONSP(object)) { 3901 result = cdr = object; 3902 /* gc protect result */ 3903 lisp__data.protect.objects[protect] = result; 3904 } 3905 else { 3906 result = cdr = CONS(CAR(object), NIL); 3907 /* gc protect result */ 3908 lisp__data.protect.objects[protect] = result; 3909 3910 /* add remaining elements to result */ 3911 for (object = CDR(object); 3912 CONSP(object); 3913 object = CDR(object)) { 3914 RPLACD(cdr, CONS(CAR(object), NIL)); 3915 cdr = CDR(cdr); 3916 } 3917 if (object != NIL) { 3918 /* object was a dotted list */ 3919 RPLACD(cdr, object); 3920 cdr = CDR(cdr); 3921 } 3922 } 3923 } 3924 } 3925 else { 3926 if (!CONSP(cdr)) 3927 LispDestroy("EVAL: cannot append to %s", STROBJ(cdr)); 3928 3929 if (!insert) { 3930 if (list) { 3931 RPLACD(cdr, CONS(object, NIL)); 3932 cdr = CDR(cdr); 3933 } 3934 else { 3935 RPLACD(cdr, object); 3936 cdr = object; 3937 } 3938 } 3939 else { 3940 if (!CONSP(object)) { 3941 RPLACD(cdr, object); 3942 /* if object is NIL, it is a empty list appended, not 3943 * creating a dotted list. */ 3944 if (object != NIL) 3945 cdr = object; 3946 } 3947 else { 3948 for (; CONSP(object); object = CDR(object)) { 3949 RPLACD(cdr, CONS(CAR(object), NIL)); 3950 cdr = CDR(cdr); 3951 } 3952 if (object != NIL) { 3953 /* object was a dotted list */ 3954 RPLACD(cdr, object); 3955 cdr = CDR(cdr); 3956 } 3957 } 3958 } 3959 } 3960 3961 /* if last argument list element processed */ 3962 if (!list) 3963 break; 3964 } 3965 3966 lisp__data.protect.length = protect; 3967 3968 return (result); 3969} 3970 3971void 3972LispMoreEnvironment(void) 3973{ 3974 Atom_id *names; 3975 LispObj **values; 3976 3977 DISABLE_INTERRUPTS(); 3978 names = realloc(lisp__data.env.names, 3979 (lisp__data.env.space + 256) * sizeof(Atom_id)); 3980 if (names != NULL) { 3981 values = realloc(lisp__data.env.values, 3982 (lisp__data.env.space + 256) * sizeof(LispObj*)); 3983 if (values != NULL) { 3984 lisp__data.env.names = names; 3985 lisp__data.env.values = values; 3986 lisp__data.env.space += 256; 3987 ENABLE_INTERRUPTS(); 3988 return; 3989 } 3990 else 3991 free(names); 3992 } 3993 ENABLE_INTERRUPTS(); 3994 LispDestroy("out of memory"); 3995} 3996 3997void 3998LispMoreStack(void) 3999{ 4000 LispObj **values; 4001 4002 DISABLE_INTERRUPTS(); 4003 values = realloc(lisp__data.stack.values, 4004 (lisp__data.stack.space + 256) * sizeof(LispObj*)); 4005 if (values == NULL) { 4006 ENABLE_INTERRUPTS(); 4007 LispDestroy("out of memory"); 4008 } 4009 lisp__data.stack.values = values; 4010 lisp__data.stack.space += 256; 4011 ENABLE_INTERRUPTS(); 4012} 4013 4014void 4015LispMoreGlobals(LispPackage *pack) 4016{ 4017 LispObj **pairs; 4018 4019 DISABLE_INTERRUPTS(); 4020 pairs = realloc(pack->glb.pairs, 4021 (pack->glb.space + 256) * sizeof(LispObj*)); 4022 if (pairs == NULL) { 4023 ENABLE_INTERRUPTS(); 4024 LispDestroy("out of memory"); 4025 } 4026 pack->glb.pairs = pairs; 4027 pack->glb.space += 256; 4028 ENABLE_INTERRUPTS(); 4029} 4030 4031void 4032LispMoreProtects(void) 4033{ 4034 LispObj **objects; 4035 4036 DISABLE_INTERRUPTS(); 4037 objects = realloc(lisp__data.protect.objects, 4038 (lisp__data.protect.space + 256) * sizeof(LispObj*)); 4039 if (objects == NULL) { 4040 ENABLE_INTERRUPTS(); 4041 LispDestroy("out of memory"); 4042 } 4043 lisp__data.protect.objects = objects; 4044 lisp__data.protect.space += 256; 4045 ENABLE_INTERRUPTS(); 4046} 4047 4048static int 4049LispMakeEnvironment(LispArgList *alist, LispObj *values, 4050 LispObj *name, int eval, int builtin) 4051{ 4052 char *desc; 4053 int i, count, base; 4054 LispObj **symbols, **defaults, **sforms; 4055 4056#define BUILTIN_ARGUMENT(value) \ 4057 lisp__data.stack.values[lisp__data.stack.length++] = value 4058 4059/* If the index value is from register variables, this 4060 * can save some cpu time. Useful for normal arguments 4061 * that are the most common, and thus the ones that 4062 * consume more time in LispMakeEnvironment. */ 4063#define BUILTIN_NO_EVAL_ARGUMENT(index, value) \ 4064 lisp__data.stack.values[index] = value 4065 4066#define NORMAL_ARGUMENT(symbol, value) \ 4067 LispDoAddVar(symbol, value) 4068 4069 if (builtin) { 4070 base = lisp__data.stack.length; 4071 if (base + alist->num_arguments > lisp__data.stack.space) { 4072 do 4073 LispMoreStack(); 4074 while (base + alist->num_arguments > lisp__data.stack.space); 4075 } 4076 } 4077 else { 4078 base = lisp__data.env.length; 4079 if (base + alist->num_arguments > lisp__data.env.space) { 4080 do 4081 LispMoreEnvironment(); 4082 while (base + alist->num_arguments > lisp__data.env.space); 4083 } 4084 } 4085 4086 desc = alist->description; 4087 switch (*desc++) { 4088 case '.': 4089 goto normal_label; 4090 case 'o': 4091 goto optional_label; 4092 case 'k': 4093 goto key_label; 4094 case 'r': 4095 goto rest_label; 4096 case 'a': 4097 goto aux_label; 4098 default: 4099 goto done_label; 4100 } 4101 4102 4103 /* Code below is done in several almost identical loops, to avoid 4104 * checking the value of the arguments eval and builtin too much times */ 4105 4106 4107 /* Normal arguments */ 4108normal_label: 4109 i = 0; 4110 count = alist->normals.num_symbols; 4111 if (builtin) { 4112 if (eval) { 4113 for (; i < count && CONSP(values); i++, values = CDR(values)) { 4114 BUILTIN_ARGUMENT(EVAL(CAR(values))); 4115 } 4116 } 4117 else { 4118 for (; i < count && CONSP(values); i++, values = CDR(values)) { 4119 BUILTIN_NO_EVAL_ARGUMENT(base + i, CAR(values)); 4120 } 4121 /* macro BUILTIN_NO_EVAL_ARGUMENT does not update 4122 * lisp__data.stack.length, as there is no risk of GC while 4123 * adding the arguments. */ 4124 lisp__data.stack.length += i; 4125 } 4126 } 4127 else { 4128 symbols = alist->normals.symbols; 4129 if (eval) { 4130 for (; i < count && CONSP(values); i++, values = CDR(values)) { 4131 NORMAL_ARGUMENT(symbols[i], EVAL(CAR(values))); 4132 } 4133 } 4134 else { 4135 for (; i < count && CONSP(values); i++, values = CDR(values)) { 4136 NORMAL_ARGUMENT(symbols[i], CAR(values)); 4137 } 4138 } 4139 } 4140 if (i < count) 4141 LispDestroy("%s: too few arguments", STROBJ(name)); 4142 4143 switch (*desc++) { 4144 case 'o': 4145 goto optional_label; 4146 case 'k': 4147 goto key_label; 4148 case 'r': 4149 goto rest_label; 4150 case 'a': 4151 goto aux_label; 4152 default: 4153 goto done_label; 4154 } 4155 4156 /* &OPTIONAL */ 4157optional_label: 4158 i = 0; 4159 count = alist->optionals.num_symbols; 4160 defaults = alist->optionals.defaults; 4161 sforms = alist->optionals.sforms; 4162 if (builtin) { 4163 if (eval) { 4164 for (; i < count && CONSP(values); i++, values = CDR(values)) 4165 BUILTIN_ARGUMENT(EVAL(CAR(values))); 4166 for (; i < count; i++) 4167 BUILTIN_ARGUMENT(UNSPEC); 4168 } 4169 else { 4170 for (; i < count && CONSP(values); i++, values = CDR(values)) 4171 BUILTIN_ARGUMENT(CAR(values)); 4172 for (; i < count; i++) 4173 BUILTIN_ARGUMENT(UNSPEC); 4174 } 4175 } 4176 else { 4177 symbols = alist->optionals.symbols; 4178 if (eval) { 4179 for (; i < count && CONSP(values); i++, values = CDR(values)) { 4180 NORMAL_ARGUMENT(symbols[i], EVAL(CAR(values))); 4181 if (sforms[i]) { 4182 NORMAL_ARGUMENT(sforms[i], T); 4183 } 4184 } 4185 } 4186 else { 4187 for (; i < count && CONSP(values); i++, values = CDR(values)) { 4188 NORMAL_ARGUMENT(symbols[i], CAR(values)); 4189 if (sforms[i]) { 4190 NORMAL_ARGUMENT(sforms[i], T); 4191 } 4192 } 4193 } 4194 4195 /* default arguments are evaluated for macros */ 4196 for (; i < count; i++) { 4197 if (!CONSTANTP(defaults[i])) { 4198 int head = lisp__data.env.head; 4199 int lex = lisp__data.env.lex; 4200 4201 lisp__data.env.lex = base; 4202 lisp__data.env.head = lisp__data.env.length; 4203 NORMAL_ARGUMENT(symbols[i], EVAL(defaults[i])); 4204 lisp__data.env.head = head; 4205 lisp__data.env.lex = lex; 4206 } 4207 else { 4208 NORMAL_ARGUMENT(symbols[i], defaults[i]); 4209 } 4210 if (sforms[i]) { 4211 NORMAL_ARGUMENT(sforms[i], NIL); 4212 } 4213 } 4214 } 4215 switch (*desc++) { 4216 case 'k': 4217 goto key_label; 4218 case 'r': 4219 goto rest_label; 4220 case 'a': 4221 goto aux_label; 4222 default: 4223 goto done_label; 4224 } 4225 4226 /* &KEY */ 4227key_label: 4228 { 4229 int argc, nused; 4230 LispObj *val, *karg, **keys; 4231 4232 /* Count number of remaining arguments */ 4233 for (karg = values, argc = 0; CONSP(karg); karg = CDR(karg), argc++) { 4234 karg = CDR(karg); 4235 if (!CONSP(karg)) 4236 LispDestroy("%s: &KEY needs arguments as pairs", 4237 STROBJ(name)); 4238 } 4239 4240 4241 /* OPTIMIZATION: 4242 * Builtin functions require that the keyword be in the keyword package. 4243 * User functions don't need the arguments being pushed in the stack 4244 * in the declared order (bytecode expects it...). 4245 * XXX Error checking should be done elsewhere, code may be looping 4246 * and doing error check here may consume too much cpu time. 4247 * XXX Would also be good to already have the arguments specified in 4248 * the correct order. 4249 */ 4250 4251 4252 nused = 0; 4253 val = NIL; 4254 count = alist->keys.num_symbols; 4255 symbols = alist->keys.symbols; 4256 defaults = alist->keys.defaults; 4257 sforms = alist->keys.sforms; 4258 if (builtin) { 4259 4260 /* Arguments must be created in the declared order */ 4261 i = 0; 4262 if (eval) { 4263 for (; i < count; i++) { 4264 for (karg = values; CONSP(karg); karg = CDDR(karg)) { 4265 /* This is only true if both point to the 4266 * same symbol in the keyword package. */ 4267 if (symbols[i] == CAR(karg)) { 4268 if (karg == values) 4269 values = CDDR(values); 4270 ++nused; 4271 BUILTIN_ARGUMENT(EVAL(CADR(karg))); 4272 goto keyword_builtin_eval_used_label; 4273 } 4274 } 4275 BUILTIN_ARGUMENT(UNSPEC); 4276keyword_builtin_eval_used_label:; 4277 } 4278 } 4279 else { 4280 for (; i < count; i++) { 4281 for (karg = values; CONSP(karg); karg = CDDR(karg)) { 4282 if (symbols[i] == CAR(karg)) { 4283 if (karg == values) 4284 values = CDDR(values); 4285 ++nused; 4286 BUILTIN_ARGUMENT(CADR(karg)); 4287 goto keyword_builtin_used_label; 4288 } 4289 } 4290 BUILTIN_ARGUMENT(UNSPEC); 4291keyword_builtin_used_label:; 4292 } 4293 } 4294 4295 if (argc != nused) { 4296 /* Argument(s) may be incorrectly specified, or specified 4297 * twice (what is not an error). */ 4298 for (karg = values; CONSP(karg); karg = CDDR(karg)) { 4299 val = CAR(karg); 4300 if (KEYWORDP(val)) { 4301 for (i = 0; i < count; i++) 4302 if (symbols[i] == val) 4303 break; 4304 } 4305 else 4306 /* Just make the error test true */ 4307 i = count; 4308 4309 if (i == count) 4310 goto invalid_keyword_label; 4311 } 4312 } 4313 } 4314 4315#if 0 4316 else { 4317 /* The base offset of the atom in the stack, to check for 4318 * keywords specified twice. */ 4319 LispObj *symbol; 4320 int offset = lisp__data.env.length; 4321 4322 keys = alist->keys.keys; 4323 for (karg = values; CONSP(karg); karg = CDDR(karg)) { 4324 symbol = CAR(karg); 4325 if (SYMBOLP(symbol)) { 4326 /* Must be a keyword, but even if it is a keyword, may 4327 * be a typo, so assume it is correct. If it is not 4328 * in the argument list, it is an error. */ 4329 for (i = 0; i < count; i++) { 4330 if (!keys[i] && symbols[i] == symbol) { 4331 LispAtom *atom = symbol->data.atom; 4332 4333 /* Symbol found in the argument list. */ 4334 if (atom->offset >= offset && 4335 atom->offset < offset + nused && 4336 lisp__data.env.names[atom->offset] == 4337 atom->string) 4338 /* Specified more than once... */ 4339 goto keyword_duplicated_label; 4340 break; 4341 } 4342 } 4343 } 4344 else { 4345 Atom_id id; 4346 4347 if (!QUOTEP(symbol) || !SYMBOLP(val = symbol->data.quote)) { 4348 /* Bad argument. */ 4349 val = symbol; 4350 goto invalid_keyword_label; 4351 } 4352 4353 id = ATOMID(val); 4354 for (i = 0; i < count; i++) { 4355 if (keys[i] && ATOMID(keys[i]) == id) { 4356 LispAtom *atom = val->data.atom; 4357 4358 /* Symbol found in the argument list. */ 4359 if (atom->offset >= offset && 4360 atom->offset < offset + nused && 4361 lisp__data.env.names[atom->offset] == 4362 atom->string) 4363 /* Specified more than once... */ 4364 goto keyword_duplicated_label; 4365 break; 4366 } 4367 } 4368 } 4369 if (i == count) { 4370 /* Argument specification not found. */ 4371 val = symbol; 4372 goto invalid_keyword_label; 4373 } 4374 ++nused; 4375 if (eval) { 4376 NORMAL_ARGUMENT(symbols[i], EVAL(CADR(karg))); 4377 } 4378 else { 4379 NORMAL_ARGUMENT(symbols[i], CADR(karg)); 4380 } 4381 if (sforms[i]) { 4382 NORMAL_ARGUMENT(sforms[i], T); 4383 } 4384keyword_duplicated_label:; 4385 } 4386 4387 /* Add variables that were not specified in the function call. */ 4388 if (nused < count) { 4389 int j; 4390 4391 for (i = 0; i < count; i++) { 4392 Atom_id id = ATOMID(symbols[i]); 4393 4394 for (j = offset + nused - 1; j >= offset; j--) { 4395 if (lisp__data.env.names[j] == id) 4396 break; 4397 } 4398 4399 if (j < offset) { 4400 /* Argument not specified. Use default value */ 4401 4402 /* default arguments are evaluated for macros */ 4403 if (!CONSTANTP(defaults[i])) { 4404 int head = lisp__data.env.head; 4405 int lex = lisp__data.env.lex; 4406 4407 lisp__data.env.lex = base; 4408 lisp__data.env.head = lisp__data.env.length; 4409 NORMAL_ARGUMENT(symbols[i], EVAL(defaults[i])); 4410 lisp__data.env.head = head; 4411 lisp__data.env.lex = lex; 4412 } 4413 else { 4414 NORMAL_ARGUMENT(symbols[i], defaults[i]); 4415 } 4416 if (sforms[i]) { 4417 NORMAL_ARGUMENT(sforms[i], NIL); 4418 } 4419 } 4420 } 4421 } 4422 } 4423#else 4424 else { 4425 int varset; 4426 4427 sforms = alist->keys.sforms; 4428 keys = alist->keys.keys; 4429 4430 /* Add variables */ 4431 for (i = 0; i < alist->keys.num_symbols; i++) { 4432 val = defaults[i]; 4433 varset = 0; 4434 if (keys[i]) { 4435 Atom_id atom = ATOMID(keys[i]); 4436 4437 /* Special keyword specification, need to compare ATOMID 4438 * and keyword specification must be a quoted object */ 4439 for (karg = values; CONSP(karg); karg = CDR(karg)) { 4440 val = CAR(karg); 4441 if (QUOTEP(val) && atom == ATOMID(val->data.quote)) { 4442 val = CADR(karg); 4443 varset = 1; 4444 ++nused; 4445 break; 4446 } 4447 karg = CDR(karg); 4448 } 4449 } 4450 4451 else { 4452 /* Normal keyword specification, can compare object pointers, 4453 * as they point to the same object in the keyword package */ 4454 for (karg = values; CONSP(karg); karg = CDR(karg)) { 4455 /* Don't check if argument is a valid keyword or 4456 * special quoted keyword */ 4457 if (symbols[i] == CAR(karg)) { 4458 val = CADR(karg); 4459 varset = 1; 4460 ++nused; 4461 break; 4462 } 4463 karg = CDR(karg); 4464 } 4465 } 4466 4467 /* Add the variable to environment */ 4468 if (varset) { 4469 NORMAL_ARGUMENT(symbols[i], eval ? EVAL(val) : val); 4470 if (sforms[i]) { 4471 NORMAL_ARGUMENT(sforms[i], T); 4472 } 4473 } 4474 else { 4475 /* default arguments are evaluated for macros */ 4476 if (!CONSTANTP(val)) { 4477 int head = lisp__data.env.head; 4478 int lex = lisp__data.env.lex; 4479 4480 lisp__data.env.lex = base; 4481 lisp__data.env.head = lisp__data.env.length; 4482 NORMAL_ARGUMENT(symbols[i], EVAL(val)); 4483 lisp__data.env.head = head; 4484 lisp__data.env.lex = lex; 4485 } 4486 else { 4487 NORMAL_ARGUMENT(symbols[i], val); 4488 } 4489 if (sforms[i]) { 4490 NORMAL_ARGUMENT(sforms[i], NIL); 4491 } 4492 } 4493 } 4494 4495 if (argc != nused) { 4496 /* Argument(s) may be incorrectly specified, or specified 4497 * twice (what is not an error). */ 4498 for (karg = values; CONSP(karg); karg = CDDR(karg)) { 4499 val = CAR(karg); 4500 if (KEYWORDP(val)) { 4501 for (i = 0; i < count; i++) 4502 if (symbols[i] == val) 4503 break; 4504 } 4505 else if (QUOTEP(val) && SYMBOLP(val->data.quote)) { 4506 Atom_id atom = ATOMID(val->data.quote); 4507 4508 for (i = 0; i < count; i++) 4509 if (ATOMID(keys[i]) == atom) 4510 break; 4511 } 4512 else 4513 /* Just make the error test true */ 4514 i = count; 4515 4516 if (i == count) 4517 goto invalid_keyword_label; 4518 } 4519 } 4520 } 4521#endif 4522 goto check_aux_label; 4523 4524invalid_keyword_label: 4525 { 4526 /* If not in argument specification list... */ 4527 char function_name[36]; 4528 4529 strcpy(function_name, STROBJ(name)); 4530 LispDestroy("%s: %s is an invalid keyword", 4531 function_name, STROBJ(val)); 4532 } 4533 } 4534 4535check_aux_label: 4536 if (*desc == 'a') { 4537 /* &KEY uses all remaining arguments */ 4538 values = NIL; 4539 goto aux_label; 4540 } 4541 goto finished_label; 4542 4543 /* &REST */ 4544rest_label: 4545 if (!CONSP(values)) { 4546 if (builtin) { 4547 BUILTIN_ARGUMENT(values); 4548 } 4549 else { 4550 NORMAL_ARGUMENT(alist->rest, values); 4551 } 4552 values = NIL; 4553 } 4554 /* always allocate a new list, don't know if it will be retained */ 4555 else if (eval) { 4556 LispObj *cons; 4557 4558 cons = CONS(EVAL(CAR(values)), NIL); 4559 if (builtin) { 4560 BUILTIN_ARGUMENT(cons); 4561 } 4562 else { 4563 NORMAL_ARGUMENT(alist->rest, cons); 4564 } 4565 values = CDR(values); 4566 for (; CONSP(values); values = CDR(values)) { 4567 RPLACD(cons, CONS(EVAL(CAR(values)), NIL)); 4568 cons = CDR(cons); 4569 } 4570 } 4571 else { 4572 LispObj *cons; 4573 4574 cons = CONS(CAR(values), NIL); 4575 if (builtin) { 4576 BUILTIN_ARGUMENT(cons); 4577 } 4578 else { 4579 NORMAL_ARGUMENT(alist->rest, cons); 4580 } 4581 values = CDR(values); 4582 for (; CONSP(values); values = CDR(values)) { 4583 RPLACD(cons, CONS(CAR(values), NIL)); 4584 cons = CDR(cons); 4585 } 4586 } 4587 if (*desc != 'a') 4588 goto finished_label; 4589 4590 /* &AUX */ 4591aux_label: 4592 i = 0; 4593 count = alist->auxs.num_symbols; 4594 defaults = alist->auxs.initials; 4595 symbols = alist->auxs.symbols; 4596 { 4597 int lex = lisp__data.env.lex; 4598 4599 lisp__data.env.lex = base; 4600 lisp__data.env.head = lisp__data.env.length; 4601 for (; i < count; i++) { 4602 NORMAL_ARGUMENT(symbols[i], EVAL(defaults[i])); 4603 ++lisp__data.env.head; 4604 } 4605 lisp__data.env.lex = lex; 4606 } 4607 4608done_label: 4609 if (CONSP(values)) 4610 LispDestroy("%s: too many arguments", STROBJ(name)); 4611 4612finished_label: 4613 if (builtin) 4614 lisp__data.stack.base = base; 4615 else { 4616 lisp__data.env.head = lisp__data.env.length; 4617 } 4618#undef BULTIN_ARGUMENT 4619#undef NORMAL_ARGUMENT 4620#undef BUILTIN_NO_EVAL_ARGUMENT 4621 4622 return (base); 4623} 4624 4625LispObj * 4626LispFuncall(LispObj *function, LispObj *arguments, int eval) 4627{ 4628 LispAtom *atom; 4629 LispArgList *alist; 4630 LispBuiltin *builtin; 4631 LispObj *lambda, *result; 4632 int macro, base; 4633 4634#ifdef DEBUGGER 4635 if (lisp__data.debugging) 4636 LispDebugger(LispDebugCallBegin, function, arguments); 4637#endif 4638 4639 switch (OBJECT_TYPE(function)) { 4640 case LispFunction_t: 4641 function = function->data.atom->object; 4642 case LispAtom_t: 4643 atom = function->data.atom; 4644 if (atom->a_builtin) { 4645 builtin = atom->property->fun.builtin; 4646 4647 if (eval) 4648 eval = builtin->type != LispMacro; 4649 base = LispMakeEnvironment(atom->property->alist, 4650 arguments, function, eval, 1); 4651 if (builtin->multiple_values) { 4652 RETURN_COUNT = 0; 4653 result = builtin->function(builtin); 4654 } 4655 else { 4656 result = builtin->function(builtin); 4657 RETURN_COUNT = 0; 4658 } 4659 lisp__data.stack.base = lisp__data.stack.length = base; 4660 } 4661 else if (atom->a_compiled) { 4662 int lex = lisp__data.env.lex; 4663 lambda = atom->property->fun.function; 4664 alist = atom->property->alist; 4665 4666 base = LispMakeEnvironment(alist, arguments, function, eval, 0); 4667 lisp__data.env.lex = base; 4668 result = LispExecuteBytecode(lambda); 4669 lisp__data.env.lex = lex; 4670 lisp__data.env.head = lisp__data.env.length = base; 4671 } 4672 else if (atom->a_function) { 4673 lambda = atom->property->fun.function; 4674 macro = lambda->funtype == LispMacro; 4675 alist = atom->property->alist; 4676 4677 lambda = lambda->data.lambda.code; 4678 if (eval) 4679 eval = !macro; 4680 base = LispMakeEnvironment(alist, arguments, function, eval, 0); 4681 result = LispRunFunMac(function, lambda, macro, base); 4682 } 4683 else if (atom->a_defstruct && 4684 atom->property->structure.function != STRUCT_NAME) { 4685 LispObj cons; 4686 4687 if (atom->property->structure.function == STRUCT_CONSTRUCTOR) 4688 atom = Omake_struct->data.atom; 4689 else if (atom->property->structure.function == STRUCT_CHECK) 4690 atom = Ostruct_type->data.atom; 4691 else 4692 atom = Ostruct_access->data.atom; 4693 builtin = atom->property->fun.builtin; 4694 4695 cons.type = LispCons_t; 4696 cons.data.cons.cdr = arguments; 4697 if (eval) { 4698 LispObj quote; 4699 4700 quote.type = LispQuote_t; 4701 quote.data.quote = function; 4702 cons.data.cons.car = "e; 4703 base = LispMakeEnvironment(atom->property->alist, 4704 &cons, function, 1, 1); 4705 } 4706 else { 4707 cons.data.cons.car = function; 4708 base = LispMakeEnvironment(atom->property->alist, 4709 &cons, function, 0, 1); 4710 } 4711 result = builtin->function(builtin); 4712 RETURN_COUNT = 0; 4713 lisp__data.stack.length = base; 4714 } 4715 else { 4716 LispDestroy("EVAL: the function %s is not defined", 4717 STROBJ(function)); 4718 /*NOTREACHED*/ 4719 result = NIL; 4720 } 4721 break; 4722 case LispLambda_t: 4723 lambda = function->data.lambda.code; 4724 alist = (LispArgList*)function->data.lambda.name->data.opaque.data; 4725 base = LispMakeEnvironment(alist, arguments, function, eval, 0); 4726 result = LispRunFunMac(function, lambda, 0, base); 4727 break; 4728 case LispCons_t: 4729 if (CAR(function) == Olambda) { 4730 function = EVAL(function); 4731 if (LAMBDAP(function)) { 4732 GC_ENTER(); 4733 4734 GC_PROTECT(function); 4735 lambda = function->data.lambda.code; 4736 alist = (LispArgList*)function->data.lambda.name->data.opaque.data; 4737 base = LispMakeEnvironment(alist, arguments, NIL, eval, 0); 4738 result = LispRunFunMac(NIL, lambda, 0, base); 4739 GC_LEAVE(); 4740 break; 4741 } 4742 } 4743 default: 4744 LispDestroy("EVAL: %s is invalid as a function", 4745 STROBJ(function)); 4746 /*NOTREACHED*/ 4747 result = NIL; 4748 break; 4749 } 4750 4751#ifdef DEBUGGER 4752 if (lisp__data.debugging) 4753 LispDebugger(LispDebugCallEnd, function, result); 4754#endif 4755 4756 return (result); 4757} 4758 4759LispObj * 4760LispEval(LispObj *object) 4761{ 4762 LispObj *result; 4763 4764 switch (OBJECT_TYPE(object)) { 4765 case LispAtom_t: 4766 if ((result = LispDoGetVar(object)) == NULL) 4767 LispDestroy("EVAL: the variable %s is unbound", STROBJ(object)); 4768 break; 4769 case LispCons_t: 4770 result = LispFuncall(CAR(object), CDR(object), 1); 4771 break; 4772 case LispQuote_t: 4773 result = object->data.quote; 4774 break; 4775 case LispFunctionQuote_t: 4776 result = object->data.quote; 4777 if (SYMBOLP(result)) 4778 result = LispSymbolFunction(result); 4779 else if (CONSP(result) && CAR(result) == Olambda) 4780 result = EVAL(result); 4781 else 4782 LispDestroy("FUNCTION: %s is not a function", STROBJ(result)); 4783 break; 4784 case LispBackquote_t: 4785 result = LispEvalBackquote(object->data.quote, 1); 4786 break; 4787 case LispComma_t: 4788 LispDestroy("EVAL: comma outside of backquote"); 4789 default: 4790 result = object; 4791 break; 4792 } 4793 4794 return (result); 4795} 4796 4797LispObj * 4798LispApply1(LispObj *function, LispObj *argument) 4799{ 4800 LispObj arguments; 4801 4802 arguments.type = LispCons_t; 4803 arguments.data.cons.car = argument; 4804 arguments.data.cons.cdr = NIL; 4805 4806 return (LispFuncall(function, &arguments, 0)); 4807} 4808 4809LispObj * 4810LispApply2(LispObj *function, LispObj *argument1, LispObj *argument2) 4811{ 4812 LispObj arguments, cdr; 4813 4814 arguments.type = cdr.type = LispCons_t; 4815 arguments.data.cons.car = argument1; 4816 arguments.data.cons.cdr = &cdr; 4817 cdr.data.cons.car = argument2; 4818 cdr.data.cons.cdr = NIL; 4819 4820 return (LispFuncall(function, &arguments, 0)); 4821} 4822 4823LispObj * 4824LispApply3(LispObj *function, LispObj *arg1, LispObj *arg2, LispObj *arg3) 4825{ 4826 LispObj arguments, car, cdr; 4827 4828 arguments.type = car.type = cdr.type = LispCons_t; 4829 arguments.data.cons.car = arg1; 4830 arguments.data.cons.cdr = &car; 4831 car.data.cons.car = arg2; 4832 car.data.cons.cdr = &cdr; 4833 cdr.data.cons.car = arg3; 4834 cdr.data.cons.cdr = NIL; 4835 4836 return (LispFuncall(function, &arguments, 0)); 4837} 4838 4839static LispObj * 4840LispRunFunMac(LispObj *name, LispObj *code, int macro, int base) 4841{ 4842 LispObj *result = NIL; 4843 4844 if (!macro) { 4845 int lex = lisp__data.env.lex; 4846 int did_jump = 1; 4847 LispBlock *block; 4848 4849 block = LispBeginBlock(name, LispBlockClosure); 4850 lisp__data.env.lex = base; 4851 if (setjmp(block->jmp) == 0) { 4852 for (; CONSP(code); code = CDR(code)) 4853 result = EVAL(CAR(code)); 4854 did_jump = 0; 4855 } 4856 LispEndBlock(block); 4857 if (did_jump) 4858 result = lisp__data.block.block_ret; 4859 lisp__data.env.lex = lex; 4860 lisp__data.env.head = lisp__data.env.length = base; 4861 } 4862 else { 4863 GC_ENTER(); 4864 4865 for (; CONSP(code); code = CDR(code)) 4866 result = EVAL(CAR(code)); 4867 /* FIXME this does not work if macro has &aux variables, 4868 * but there are several other missing features, like 4869 * destructuring and more lambda list keywords still missing. 4870 * TODO later. 4871 */ 4872 lisp__data.env.head = lisp__data.env.length = base; 4873 4874 GC_PROTECT(result); 4875 result = EVAL(result); 4876 GC_LEAVE(); 4877 } 4878 4879 return (result); 4880} 4881 4882LispObj * 4883LispRunSetf(LispArgList *alist, LispObj *setf, LispObj *place, LispObj *value) 4884{ 4885 GC_ENTER(); 4886 LispObj *store, *code, *expression, *result, quote; 4887 int base; 4888 4889 code = setf->data.lambda.code; 4890 store = setf->data.lambda.data; 4891 4892 quote.type = LispQuote_t; 4893 quote.data.quote = value; 4894 LispDoAddVar(CAR(store), "e); 4895 ++lisp__data.env.head; 4896 base = LispMakeEnvironment(alist, place, Oexpand_setf_method, 0, 0); 4897 4898 /* build expansion macro */ 4899 expression = NIL; 4900 for (; CONSP(code); code = CDR(code)) 4901 expression = EVAL(CAR(code)); 4902 4903 /* Minus 1 to pop the added variable */ 4904 lisp__data.env.head = lisp__data.env.length = base - 1; 4905 4906 /* protect expansion, and executes it */ 4907 GC_PROTECT(expression); 4908 result = EVAL(expression); 4909 GC_LEAVE(); 4910 4911 return (result); 4912} 4913 4914LispObj * 4915LispRunSetfMacro(LispAtom *atom, LispObj *arguments, LispObj *value) 4916{ 4917 int base; 4918 GC_ENTER(); 4919 LispObj *place, *body, *result, quote; 4920 4921 place = NIL; 4922 base = LispMakeEnvironment(atom->property->alist, 4923 arguments, atom->object, 0, 0); 4924 body = atom->property->fun.function->data.lambda.code; 4925 4926 /* expand macro body */ 4927 for (; CONSP(body); body = CDR(body)) 4928 place = EVAL(CAR(body)); 4929 4930 /* protect expansion */ 4931 GC_PROTECT(place); 4932 4933 /* restore environment */ 4934 lisp__data.env.head = lisp__data.env.length = base; 4935 4936 /* value is already evaluated */ 4937 quote.type = LispQuote_t; 4938 quote.data.quote = value; 4939 4940 /* call setf again */ 4941 result = APPLY2(Osetf, place, "e); 4942 4943 GC_LEAVE(); 4944 4945 return (result); 4946} 4947 4948char * 4949LispStrObj(LispObj *object) 4950{ 4951 static int first = 1; 4952 static char buffer[34]; 4953 static LispObj stream; 4954 static LispString string; 4955 4956 if (first) { 4957 stream.type = LispStream_t; 4958 stream.data.stream.source.string = &string; 4959 stream.data.stream.pathname = NIL; 4960 stream.data.stream.type = LispStreamString; 4961 stream.data.stream.readable = 0; 4962 stream.data.stream.writable = 1; 4963 4964 string.string = buffer; 4965 string.fixed = 1; 4966 string.space = sizeof(buffer) - 1; 4967 first = 0; 4968 } 4969 4970 string.length = string.output = 0; 4971 4972 LispWriteObject(&stream, object); 4973 4974 /* make sure string is nul terminated */ 4975 string.string[string.length] = '\0'; 4976 if (string.length >= 32) { 4977 if (buffer[0] == '(') 4978 strcpy(buffer + 27, "...)"); 4979 else 4980 strcpy(buffer + 28, "..."); 4981 } 4982 4983 return (buffer); 4984} 4985 4986void 4987LispPrint(LispObj *object, LispObj *stream, int newline) 4988{ 4989 if (stream != NIL && !STREAMP(stream)) { 4990 LispDestroy("PRINT: %s is not a stream", STROBJ(stream)); 4991 } 4992 if (newline && LispGetColumn(stream)) 4993 LispWriteChar(stream, '\n'); 4994 LispWriteObject(stream, object); 4995 if (stream == NIL || (stream->data.stream.type == LispStreamStandard && 4996 stream->data.stream.source.file == Stdout)) 4997 LispFflush(Stdout); 4998} 4999 5000void 5001LispUpdateResults(LispObj *cod, LispObj *res) 5002{ 5003 LispSetVar(RUN[2], LispGetVar(RUN[1])); 5004 LispSetVar(RUN[1], LispGetVar(RUN[0])); 5005 LispSetVar(RUN[0], cod); 5006 5007 LispSetVar(RES[2], LispGetVar(RES[1])); 5008 LispSetVar(RES[1], LispGetVar(RES[0])); 5009 LispSetVar(RES[0], res); 5010} 5011 5012#ifdef SIGNALRETURNSINT 5013int 5014#else 5015void 5016#endif 5017LispSignalHandler(int signum) 5018{ 5019 LispSignal(signum); 5020#ifdef SIGNALRETURNSINT 5021 return (0); 5022#endif 5023} 5024 5025void 5026LispSignal(int signum) 5027{ 5028 char *errstr; 5029 char buffer[32]; 5030 5031 if (lisp__disable_int) { 5032 lisp__interrupted = signum; 5033 return; 5034 } 5035 switch (signum) { 5036 case SIGINT: 5037 errstr = "interrupted"; 5038 break; 5039 case SIGFPE: 5040 errstr = "floating point exception"; 5041 break; 5042 default: 5043 sprintf(buffer, "signal %d received", signum); 5044 errstr = buffer; 5045 break; 5046 } 5047 LispDestroy(errstr); 5048} 5049 5050void 5051LispDisableInterrupts(void) 5052{ 5053 ++lisp__disable_int; 5054} 5055 5056void 5057LispEnableInterrupts(void) 5058{ 5059 --lisp__disable_int; 5060 if (lisp__disable_int <= 0 && lisp__interrupted) 5061 LispSignal(lisp__interrupted); 5062} 5063 5064void 5065LispMachine(void) 5066{ 5067 LispObj *cod, *obj; 5068 5069 lisp__data.sigint = signal(SIGINT, LispSignalHandler); 5070 lisp__data.sigfpe = signal(SIGFPE, LispSignalHandler); 5071 5072 /*CONSTCOND*/ 5073 while (1) { 5074 if (sigsetjmp(lisp__data.jmp, 1) == 0) { 5075 lisp__data.running = 1; 5076 if (lisp__data.interactive && lisp__data.prompt) { 5077 LispFputs(Stdout, lisp__data.prompt); 5078 LispFflush(Stdout); 5079 } 5080 if ((cod = LispRead()) != NULL) { 5081 obj = EVAL(cod); 5082 if (lisp__data.interactive) { 5083 if (RETURN_COUNT >= 0) 5084 LispPrint(obj, NIL, 1); 5085 if (RETURN_COUNT > 0) { 5086 int i; 5087 5088 for (i = 0; i < RETURN_COUNT; i++) 5089 LispPrint(RETURN(i), NIL, 1); 5090 } 5091 LispUpdateResults(cod, obj); 5092 if (LispGetColumn(NIL)) 5093 LispWriteChar(NIL, '\n'); 5094 } 5095 } 5096 LispTopLevel(); 5097 } 5098 if (lisp__data.eof) 5099 break; 5100 } 5101 5102 signal(SIGINT, lisp__data.sigint); 5103 signal(SIGFPE, lisp__data.sigfpe); 5104 5105 lisp__data.running = 0; 5106} 5107 5108void * 5109LispExecute(char *str) 5110{ 5111 static LispObj stream; 5112 static LispString string; 5113 static int first = 1; 5114 5115 int running = lisp__data.running; 5116 LispObj *result, *cod, *obj, **presult = &result; 5117 5118 if (str == NULL || *str == '\0') 5119 return (NIL); 5120 5121 *presult = NIL; 5122 5123 if (first) { 5124 stream.type = LispStream_t; 5125 stream.data.stream.source.string = &string; 5126 stream.data.stream.pathname = NIL; 5127 stream.data.stream.type = LispStreamString; 5128 stream.data.stream.readable = 1; 5129 stream.data.stream.writable = 0; 5130 string.output = 0; 5131 first = 0; 5132 } 5133 string.string = str; 5134 string.length = strlen(str); 5135 string.input = 0; 5136 5137 LispPushInput(&stream); 5138 if (!running) { 5139 lisp__data.running = 1; 5140 if (sigsetjmp(lisp__data.jmp, 1) != 0) 5141 return (NULL); 5142 } 5143 5144 cod = COD; 5145 /*CONSTCOND*/ 5146 while (1) { 5147 if ((obj = LispRead()) != NULL) { 5148 result = EVAL(obj); 5149 COD = cod; 5150 } 5151 if (lisp__data.eof) 5152 break; 5153 } 5154 LispPopInput(&stream); 5155 5156 lisp__data.running = running; 5157 5158 return (result); 5159} 5160 5161void 5162LispBegin(void) 5163{ 5164 int i; 5165 LispAtom *atom; 5166 char results[4]; 5167 LispObj *object, *path, *ext; 5168 5169 pagesize = LispGetPageSize(); 5170 segsize = pagesize / sizeof(LispObj); 5171 5172 lisp__data.strings = hash_new(STRTBLSZ, NULL); 5173 lisp__data.opqs = hash_new(STRTBLSZ, NULL); 5174 5175 /* Initialize memory management */ 5176 lisp__data.mem.mem = (void**)calloc(lisp__data.mem.space = 16, 5177 sizeof(void*)); 5178 lisp__data.mem.index = lisp__data.mem.level = 0; 5179 5180 /* Allow LispGetVar to check ATOMID() of unbound symbols */ 5181 UNBOUND->data.atom = (LispAtom*)LispCalloc(1, sizeof(LispAtom)); 5182 LispMused(UNBOUND->data.atom); 5183 noproperty.value = UNBOUND; 5184 5185 if (Stdin == NULL) 5186 Stdin = LispFdopen(0, FILE_READ); 5187 if (Stdout == NULL) 5188 Stdout = LispFdopen(1, FILE_WRITE | FILE_BUFFERED); 5189 if (Stderr == NULL) 5190 Stderr = LispFdopen(2, FILE_WRITE); 5191 5192 /* minimum number of free cells after GC 5193 * if sizeof(LispObj) == 16, than a minfree of 1024 would try to keep 5194 * at least 16Kb of free cells. 5195 */ 5196 minfree = 1024; 5197 5198 MOD = COD = PRO = NIL; 5199#ifdef DEBUGGER 5200 DBG = BRK = NIL; 5201#endif 5202 5203 /* allocate initial object cells */ 5204 LispAllocSeg(&objseg, minfree); 5205 LispAllocSeg(&atomseg, pagesize); 5206 lisp__data.gc.average = segsize; 5207 5208 /* Don't allow gc in initialization */ 5209 GCDisable(); 5210 5211 /* Initialize package system, the current package is LISP. Order of 5212 * initialization is very important here */ 5213 lisp__data.lisp = LispNewPackage(STRING("LISP"), 5214 CONS(STRING("COMMON-LISP"), NIL)); 5215 5216 /* Make LISP package the current one */ 5217 lisp__data.pack = lisp__data.savepack = 5218 lisp__data.lisp->data.package.package; 5219 5220 /* Allocate space in LISP package */ 5221 LispMoreGlobals(lisp__data.pack); 5222 5223 /* Allocate space for multiple value return values */ 5224 lisp__data.returns.values = malloc(MULTIPLE_VALUES_LIMIT * 5225 (sizeof(LispObj*))); 5226 5227 /* Create the first atom, do it "by hand" because macro "PACKAGE" 5228 * cannot yet be used. */ 5229 atom = LispGetPermAtom("*PACKAGE*"); 5230 lisp__data.package = atomseg.freeobj; 5231 atomseg.freeobj = CDR(atomseg.freeobj); 5232 --atomseg.nfree; 5233 lisp__data.package->type = LispAtom_t; 5234 lisp__data.package->data.atom = atom; 5235 atom->object = lisp__data.package; 5236 atom->package = lisp__data.lisp; 5237 5238 /* Set package list, to be used by (gc) and (list-all-packages) */ 5239 PACK = CONS(lisp__data.lisp, NIL); 5240 5241 /* Make *PACKAGE* a special variable */ 5242 LispProclaimSpecial(lisp__data.package, lisp__data.lisp, NIL); 5243 5244 /* Value of macro "PACKAGE" is now properly available */ 5245 5246 /* Changing *PACKAGE* is like calling (in-package) */ 5247 lisp__data.package->data.atom->watch = 1; 5248 5249 /* And available to other packages */ 5250 LispExportSymbol(lisp__data.package); 5251 5252 /* Initialize stacks */ 5253 LispMoreEnvironment(); 5254 LispMoreStack(); 5255 5256 /* Create the KEYWORD package */ 5257 Skeyword = GETATOMID("KEYWORD"); 5258 object = LispNewPackage(STRING(Skeyword->value), 5259 CONS(STRING(""), NIL)); 5260 5261 /* Update list of packages */ 5262 PACK = CONS(object, PACK); 5263 5264 /* Allow easy access to the keyword package */ 5265 lisp__data.keyword = object; 5266 lisp__data.key = object->data.package.package; 5267 5268 /* Initialize some static important symbols */ 5269 Olambda = STATIC_ATOM("LAMBDA"); 5270 LispExportSymbol(Olambda); 5271 Okey = STATIC_ATOM("&KEY"); 5272 LispExportSymbol(Okey); 5273 Orest = STATIC_ATOM("&REST"); 5274 LispExportSymbol(Orest); 5275 Ooptional = STATIC_ATOM("&OPTIONAL"); 5276 LispExportSymbol(Ooptional); 5277 Oaux = STATIC_ATOM("&AUX"); 5278 LispExportSymbol(Oaux); 5279 Kunspecific = KEYWORD("UNSPECIFIC"); 5280 Oformat = STATIC_ATOM("FORMAT"); 5281 Oexpand_setf_method = STATIC_ATOM("EXPAND-SETF-METHOD"); 5282 5283 Omake_struct = STATIC_ATOM("MAKE-STRUCT"); 5284 Ostruct_access = STATIC_ATOM("STRUCT-ACCESS"); 5285 Ostruct_store = STATIC_ATOM("STRUCT-STORE"); 5286 Ostruct_type = STATIC_ATOM("STRUCT-TYPE"); 5287 Smake_struct = ATOMID(Omake_struct); 5288 Sstruct_access = ATOMID(Ostruct_access); 5289 Sstruct_store = ATOMID(Ostruct_store); 5290 Sstruct_type = ATOMID(Ostruct_type); 5291 5292 /* Initialize some static atom ids */ 5293 Snil = GETATOMID("NIL"); 5294 St = GETATOMID("T"); 5295 Saux = ATOMID(Oaux); 5296 Skey = ATOMID(Okey); 5297 Soptional = ATOMID(Ooptional); 5298 Srest = ATOMID(Orest); 5299 Sand = GETATOMID("AND"); 5300 Sor = GETATOMID("OR"); 5301 Snot = GETATOMID("NOT"); 5302 Satom = GETATOMID("ATOM"); 5303 Ssymbol = GETATOMID("SYMBOL"); 5304 Sinteger = GETATOMID("INTEGER"); 5305 Scharacter = GETATOMID("CHARACTER"); 5306 Sstring = GETATOMID("STRING"); 5307 Slist = GETATOMID("LIST"); 5308 Scons = GETATOMID("CONS"); 5309 Svector = GETATOMID("VECTOR"); 5310 Sarray = GETATOMID("ARRAY"); 5311 Sstruct = GETATOMID("STRUCT"); 5312 Sfunction = GETATOMID("FUNCTION"); 5313 Spathname = GETATOMID("PATHNAME"); 5314 Srational = GETATOMID("RATIONAL"); 5315 Sfloat = GETATOMID("FLOAT"); 5316 Scomplex = GETATOMID("COMPLEX"); 5317 Sopaque = GETATOMID("OPAQUE"); 5318 Sdefault = GETATOMID("DEFAULT"); 5319 5320 LispArgList_t = LispRegisterOpaqueType("LispArgList*"); 5321 5322 lisp__data.unget = malloc(sizeof(LispUngetInfo*)); 5323 lisp__data.unget[0] = calloc(1, sizeof(LispUngetInfo)); 5324 lisp__data.nunget = 1; 5325 5326 lisp__data.standard_input = ATOM2("*STANDARD-INPUT*"); 5327 SINPUT = STANDARDSTREAM(Stdin, lisp__data.standard_input, STREAM_READ); 5328 lisp__data.interactive = 1; 5329 LispProclaimSpecial(lisp__data.standard_input, 5330 lisp__data.input_list = SINPUT, NIL); 5331 LispExportSymbol(lisp__data.standard_input); 5332 5333 lisp__data.standard_output = ATOM2("*STANDARD-OUTPUT*"); 5334 SOUTPUT = STANDARDSTREAM(Stdout, lisp__data.standard_output, STREAM_WRITE); 5335 LispProclaimSpecial(lisp__data.standard_output, 5336 lisp__data.output_list = SOUTPUT, NIL); 5337 LispExportSymbol(lisp__data.standard_output); 5338 5339 object = ATOM2("*STANDARD-ERROR*"); 5340 lisp__data.error_stream = STANDARDSTREAM(Stderr, object, STREAM_WRITE); 5341 LispProclaimSpecial(object, lisp__data.error_stream, NIL); 5342 LispExportSymbol(object); 5343 5344 lisp__data.modules = ATOM2("*MODULES*"); 5345 LispProclaimSpecial(lisp__data.modules, MOD, NIL); 5346 LispExportSymbol(lisp__data.modules); 5347 5348 object = CONS(KEYWORD("UNIX"), CONS(KEYWORD("XEDIT"), NIL)); 5349 lisp__data.features = ATOM2("*FEATURES*"); 5350 LispProclaimSpecial(lisp__data.features, object, NIL); 5351 LispExportSymbol(lisp__data.features); 5352 5353 object = ATOM2("MULTIPLE-VALUES-LIMIT"); 5354 LispDefconstant(object, FIXNUM(MULTIPLE_VALUES_LIMIT + 1), NIL); 5355 LispExportSymbol(object); 5356 5357 /* Reenable gc */ 5358 GCEnable(); 5359 5360 LispBytecodeInit(); 5361 LispPackageInit(); 5362 LispCoreInit(); 5363 LispMathInit(); 5364 LispPathnameInit(); 5365 LispStreamInit(); 5366 LispRegexInit(); 5367 LispWriteInit(); 5368 5369 lisp__data.prompt = isatty(0) ? "> " : NULL; 5370 5371 lisp__data.errexit = !lisp__data.interactive; 5372 5373 if (lisp__data.interactive) { 5374 /* add +, ++, +++, *, **, and *** */ 5375 for (i = 0; i < 3; i++) { 5376 results[i] = '+'; 5377 results[i + 1] = '\0'; 5378 RUN[i] = ATOM(results); 5379 LispSetVar(RUN[i], NIL); 5380 LispExportSymbol(RUN[i]); 5381 } 5382 for (i = 0; i < 3; i++) { 5383 results[i] = '*'; 5384 results[i + 1] = '\0'; 5385 RES[i] = ATOM(results); 5386 LispSetVar(RES[i], NIL); 5387 LispExportSymbol(RES[i]); 5388 } 5389 } 5390 else 5391 RUN[0] = RUN[1] = RUN[2] = RES[0] = RES[1] = RES[2] = NIL; 5392 5393 /* Add LISP builtin functions */ 5394 for (i = 0; i < sizeof(lispbuiltins) / sizeof(lispbuiltins[0]); i++) 5395 LispAddBuiltinFunction(&lispbuiltins[i]); 5396 5397 EXECUTE("(require \"lisp\")"); 5398 5399 object = ATOM2("*DEFAULT-PATHNAME-DEFAULTS*"); 5400#ifdef LISPDIR 5401 { 5402 int length; 5403 char *pathname = LISPDIR; 5404 5405 length = strlen(pathname); 5406 if (length && pathname[length - 1] != '/') { 5407 pathname = LispMalloc(length + 2); 5408 5409 strcpy(pathname, LISPDIR); 5410 strcpy(pathname + length, "/"); 5411 path = LSTRING2(pathname, length + 1); 5412 } 5413 else 5414 path = LSTRING(pathname, length); 5415 } 5416#else 5417 path = STRING(""); 5418#endif 5419 GCDisable(); 5420 LispProclaimSpecial(object, APPLY1(Oparse_namestring, path), NIL); 5421 LispExportSymbol(object); 5422 GCEnable(); 5423 5424 /* Create and make EXT the current package */ 5425 PACKAGE = ext = LispNewPackage(STRING("EXT"), NIL); 5426 lisp__data.pack = lisp__data.savepack = PACKAGE->data.package.package; 5427 5428 /* Update list of packages */ 5429 PACK = CONS(ext, PACK); 5430 5431 /* Import LISP external symbols in EXT package */ 5432 LispUsePackage(lisp__data.lisp); 5433 5434 /* Add EXT non standard builtin functions */ 5435 for (i = 0; i < sizeof(extbuiltins) / sizeof(extbuiltins[0]); i++) 5436 LispAddBuiltinFunction(&extbuiltins[i]); 5437 5438 /* Create and make USER the current package */ 5439 GCDisable(); 5440 PACKAGE = LispNewPackage(STRING("USER"), 5441 CONS(STRING("COMMON-LISP-USER"), NIL)); 5442 GCEnable(); 5443 lisp__data.pack = lisp__data.savepack = PACKAGE->data.package.package; 5444 5445 /* Update list of packages */ 5446 PACK = CONS(PACKAGE, PACK); 5447 5448 /* USER package inherits all LISP external symbols */ 5449 LispUsePackage(lisp__data.lisp); 5450 /* And all EXT external symbols */ 5451 LispUsePackage(ext); 5452 5453 LispTopLevel(); 5454} 5455 5456void 5457LispEnd(void) 5458{ 5459 /* XXX needs to free all used memory, not just close file descriptors */ 5460} 5461 5462void 5463LispSetPrompt(char *prompt) 5464{ 5465 lisp__data.prompt = prompt; 5466} 5467 5468void 5469LispSetInteractive(int interactive) 5470{ 5471 lisp__data.interactive = !!interactive; 5472} 5473 5474void 5475LispSetExitOnError(int errexit) 5476{ 5477 lisp__data.errexit = !!errexit; 5478} 5479 5480void 5481LispDebug(int enable) 5482{ 5483 lisp__data.debugging = !!enable; 5484 5485#ifdef DEBUGGER 5486 /* assumes we are at the toplevel */ 5487 DBG = BRK = NIL; 5488 lisp__data.debug_level = -1; 5489 lisp__data.debug_step = 0; 5490#endif 5491} 5492