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