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