1 package uk.co.codemist.jlisp; 2 3 4 // 5 // This file is part of the Jlisp implementation of Standard Lisp 6 // Copyright \u00a9 (C) Codemist Ltd, 1998-2011. 7 // 8 9 10 // Fns3.java 11 12 /************************************************************************** 13 * Copyright (C) 1998-2011, Codemist Ltd. A C Norman * 14 * also contributions from Vijay Chauhan, 2002 * 15 * * 16 * Redistribution and use in source and binary forms, with or without * 17 * modification, are permitted provided that the following conditions are * 18 * met: * 19 * * 20 * * Redistributions of source code must retain the relevant * 21 * copyright notice, this list of conditions and the following * 22 * disclaimer. * 23 * * Redistributions in binary form must reproduce the above * 24 * copyright notice, this list of conditions and the following * 25 * disclaimer in the documentation and/or other materials provided * 26 * with the distribution. * 27 * * 28 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * 29 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * 30 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS * 31 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE * 32 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, * 33 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, * 34 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS * 35 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND * 36 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR * 37 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF * 38 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH * 39 * DAMAGE. * 40 *************************************************************************/ 41 // Each built-in function is created wrapped in a class 42 // that is derived from BuiltinFunction. 43 44 import java.io.*; 45 import java.util.*; 46 import java.util.zip.*; 47 import java.text.*; 48 import java.math.*; 49 50 class Fns3 51 { 52 Object [][] builtins = 53 { 54 {"liter", new LiterFn()}, 55 {"load-module", new Load_moduleFn()}, 56 {"lposn", new LposnFn()}, 57 {"macro-function", new Macro_functionFn()}, 58 {"macroexpand", new MacroexpandFn()}, 59 {"macroexpand-1", new Macroexpand_1Fn()}, 60 {"make-bps", new Make_bpsFn()}, 61 {"make-function-stream", new Make_function_streamFn()}, 62 {"make-global", new Make_globalFn()}, 63 {"make-native", new Make_nativeFn()}, 64 {"make-random-state", new Make_random_stateFn()}, 65 {"make-simple-string", new Make_simple_stringFn()}, 66 {"make-special", new Make_specialFn()}, 67 {"map", new MapFn()}, 68 {"mapc", new MapcFn()}, 69 {"mapcan", new MapcanFn()}, 70 {"mapcar", new MapcarFn()}, 71 {"mapcon", new MapconFn()}, 72 {"maphash", new MaphashFn()}, 73 {"maplist", new MaplistFn()}, 74 {"mapstore", new MapstoreFn()}, 75 {"md5", new Md5Fn()}, 76 {"md60", new Md60Fn()}, 77 {"member", new MemberFn()}, 78 {"member**", new MemberStarStarFn()}, 79 {"memq", new MemqFn()}, 80 {"mkevect", new MkevectFn()}, 81 {"mkfvect32", new Mkfvect32Fn()}, 82 {"mkfvect64", new Mkfvect64Fn()}, 83 {"mkhash", new MkhashFn()}, 84 {"mkquote", new MkquoteFn()}, 85 {"mkvect", new MkvectFn()}, 86 {"mkvect16", new Mkvect16Fn()}, 87 {"mkvect32", new Mkvect32Fn()}, 88 {"mkvect8", new Mkvect8Fn()}, 89 {"mkxvect", new MkxvectFn()}, 90 {"modulep", new ModulepFn()}, 91 {"native-address", new Native_addressFn()}, 92 {"native-getv", new Native_getvFn()}, 93 {"native-putv", new Native_putvFn()}, 94 {"native-type", new Native_typeFn()}, 95 {"nconc", new NconcFn()}, 96 {"ncons", new NconsFn()}, 97 {"neq", new NeqFn()}, 98 {"noisy-setq", new Noisy_setqFn()}, 99 {"not", new NotFn()}, 100 {"null", new NullFn()}, 101 {"oblist", new OblistFn()}, 102 {"oem-supervisor", new Oem_supervisorFn()}, 103 {"open", new OpenFn()}, 104 {"internal-open", new InternalOpenFn()}, 105 {"open-library", new Open_libraryFn()}, 106 {"open-url", new Open_urlFn()}, 107 {"orderp", new OrderpFn()}, 108 {"ordp", new OrderpFn()}, // synonym 109 {"output-library", new Output_libraryFn()}, 110 {"pagelength", new PagelengthFn()}, 111 {"pair", new PairFn()}, 112 {"pairp", new PairpFn()}, 113 {"peekch", new PeekchFn()}, 114 {"pipe-open", new Pipe_openFn()}, 115 {"plist", new PlistFn()}, 116 {"posn", new PosnFn()}, 117 {"preserve", new PreserveFn()}, 118 {"restart-csl", new RestartFn()}, 119 {"saveobject", new SaveObjectFn()}, 120 {"restoreobject", new RestoreObjectFn()}, 121 {"prin", new PrinFn()}, 122 {"prin1", new Prin1Fn()}, 123 {"prin2", new Prin2Fn()}, 124 {"prin2a", new Prin2aFn()}, 125 {"prinbinary", new PrinbinaryFn()}, 126 {"princ", new PrincFn()}, 127 {"princ-downcase", new Princ_downcaseFn()}, 128 {"princ-upcase", new Princ_upcaseFn()}, 129 {"prinhex", new PrinhexFn()}, 130 {"prinoctal", new PrinoctalFn()}, 131 {"print", new PrintFn()}, 132 {"printc", new PrintcFn()}, 133 {"printprompt", new PrintpromptFn()}, 134 {"prog1", new Prog1Fn()}, 135 {"prog2", new Prog2Fn()}, 136 {"progn", new PrognFn()}, 137 {"put", new PutFn()}, 138 {"puthash", new PuthashFn()}, 139 {"putv", new PutvFn()}, 140 {"putv-char", new Putv_charFn()}, 141 {"putv16", new Putv16Fn()}, 142 {"putv32", new Putv32Fn()}, 143 {"putv8", new Putv8Fn()}, 144 {"qcaar", new QcaarFn()}, 145 {"qcadr", new QcadrFn()}, 146 {"qcar", new QcarFn()}, 147 {"qcdar", new QcdarFn()}, 148 {"qcddr", new QcddrFn()}, 149 {"qcdr", new QcdrFn()}, 150 {"qgetv", new QgetvFn()}, 151 {"qputv", new QputvFn()}, 152 {"rassoc", new RassocFn()}, 153 {"rdf", new RdfFn()}, 154 {"rds", new RdsFn()}, 155 {"read", new ReadFn()}, 156 {"readch", new ReadchFn()}, 157 {"readline", new ReadlineFn()}, 158 {"reclaim", new ReclaimFn()}, 159 {"remd", new RemdFn()}, 160 {"remflag", new RemflagFn()}, 161 {"remhash", new RemhashFn()}, 162 {"remob", new RemobFn()}, 163 {"remprop", new RempropFn()}, 164 {"rename-file", new Rename_fileFn()}, 165 {"representation", new RepresentationFn()}, 166 {"return", new ReturnFn()}, 167 {"reverse", new ReverseFn()}, 168 {"reversip", new ReversipFn()}, 169 {"reversip2", new ReversipFn()}, 170 {"nreverse", new ReversipFn()}, 171 {"rplaca", new RplacaFn()}, 172 {"rplacd", new RplacdFn()}, 173 {"rplacw", new RplacwFn()}, 174 {"rseek", new RseekFn()}, 175 {"rtell", new RtellFn()}, 176 {"sample", new SampleFn()}, 177 {"sassoc", new SassocFn()}, 178 {"schar", new ScharFn()}, 179 {"seprp", new SeprpFn()}, 180 {"set", new SetFn()}, 181 {"set-autoload", new Set_autoloadFn()}, 182 {"set-help-file", new Set_help_fileFn()}, 183 {"set-print-precision", new Set_print_precisionFn()}, 184 {"setprintprecision", new Set_print_precisionFn()}, 185 {"getprintprecision", new Get_print_precisionFn()}, 186 {"setpchar", new SetpcharFn()}, 187 {"simple-string-p", new Simple_string_pFn()}, 188 {"simple-vector-p", new Simple_vector_pFn()}, 189 {"smemq", new SmemqFn()}, 190 {"spaces", new SpacesFn()}, 191 {"special-char", new Special_charFn()}, 192 {"special-form-p", new Special_form_pFn()}, 193 {"spool", new SpoolFn()}, 194 {"start-module", new Start_moduleFn()}, 195 {"stop", new StopFn()}, 196 {"streamp", new StreampFn()}, 197 {"stringp", new StringpFn()}, 198 {"stub1", new Stub1Fn()}, 199 {"stub2", new Stub2Fn()}, 200 {"subla", new SublaFn()}, 201 {"sublis", new SublisFn()}, 202 {"subst", new SubstFn()}, 203 {"substq", new SubstqFn()}, 204 {"sxhash", new SxhashFn()}, 205 // equalhash is NOT really sorted out yet since it ought not to 206 // descend through vectors. 207 {"equalhash", new SxhashFn()}, 208 {"symbol-argcount", new Symbol_argcountFn()}, 209 {"symbol-env", new Symbol_envFn()}, 210 {"symbol-fastgets", new Symbol_fastgetsFn()}, 211 {"symbol-fn-cell", new Symbol_fn_cellFn()}, 212 {"symbol-function", new Symbol_functionFn()}, 213 {"symbol-make-fastget", new Symbol_make_fastgetFn()}, 214 {"symbol-name", new Symbol_nameFn()}, 215 {"symbol-protect", new Symbol_protectFn()}, 216 {"symbol-set-definition", new Symbol_set_definitionFn()}, 217 {"symbol-set-env", new Symbol_set_envFn()}, 218 {"symbol-set-native", new Symbol_set_nativeFn()}, 219 {"symbol-value", new Symbol_valueFn()}, 220 {"symbolp", new SymbolpFn()}, 221 {"symerr", new SymerrFn()}, 222 {"system", new SystemFn()}, 223 {"tagbody", new TagbodyFn()}, 224 {"terpri", new TerpriFn()}, 225 {"threevectorp", new ThreevectorpFn()}, 226 {"throw", new ThrowFn()}, 227 {"time", new TimeFn()}, 228 {"tmpnam", new TmpnamFn()}, 229 {"trace", new TraceFn()}, 230 {"traceset", new TracesetFn()}, 231 {"traceset1", new Traceset1Fn()}, 232 {"ttab", new TtabFn()}, 233 {"tyo", new TyoFn()}, 234 {"undouble-execute", new Undouble_executeFn()}, 235 {"unfluid", new UnfluidFn()}, 236 {"unglobal", new UnglobalFn()}, 237 {"union", new UnionFn()}, 238 {"unmake-global", new Unmake_globalFn()}, 239 {"unmake-special", new Unmake_specialFn()}, 240 {"unreadch", new UnreadchFn()}, 241 {"untrace", new UntraceFn()}, 242 {"untraceset", new UntracesetFn()}, 243 {"untraceset1", new Untraceset1Fn()}, 244 {"unwind-protect", new Unwind_protectFn()}, 245 {"upbv", new UpbvFn()}, 246 {"user-homedir-pathname", new User_homedir_pathnameFn()}, 247 {"vectorp", new VectorpFn()}, 248 {"verbos", new VerbosFn()}, 249 {"where-was-that", new Where_was_thatFn()}, 250 {"window-heading", new Window_headingFn()}, 251 {"startup-banner", new Startup_bannerFn()}, 252 {"writable-libraryp", new Writable_librarypFn()}, 253 {"write-help-module", new Write_help_moduleFn()}, 254 {"write-module", new Write_moduleFn()}, 255 {"wrs", new WrsFn()}, 256 {"xassoc", new XassocFn()}, 257 {"xcons", new XconsFn()}, 258 {"xdifference", new XdifferenceFn()}, 259 {"xtab", new XtabFn()}, 260 {"~tyi", new TyiFn()} 261 }; 262 263 264 265 class LiterFn extends BuiltinFunction 266 { op1(LispObject arg1)267 public LispObject op1(LispObject arg1) throws Exception 268 { 269 if (!(arg1 instanceof Symbol)) return Jlisp.nil; 270 Symbol s = (Symbol)arg1; 271 s.completeName(); 272 char ch = s.pname.charAt(0); 273 if (Character.isLetter(ch)) return Jlisp.lispTrue; 274 else return Jlisp.nil; 275 } 276 } 277 278 279 class Load_moduleFn extends BuiltinFunction 280 { op1(LispObject arg1)281 public LispObject op1(LispObject arg1) throws Exception 282 { 283 return Fasl.loadModule(arg1); 284 } 285 } 286 287 class LposnFn extends BuiltinFunction 288 { op1(LispObject arg1)289 public LispObject op1(LispObject arg1) throws Exception 290 { 291 return error(name + " not yet implemented"); 292 } 293 } 294 295 class Macro_functionFn extends BuiltinFunction 296 { op1(LispObject arg1)297 public LispObject op1(LispObject arg1) throws Exception 298 { 299 if (!(arg1 instanceof Symbol)) return Jlisp.nil; 300 LispFunction fn = ((Symbol)arg1).fn; 301 if (fn instanceof Macro) 302 { return ((Macro)fn).body; 303 } 304 else return Jlisp.nil; 305 } 306 } 307 308 class MacroexpandFn extends BuiltinFunction 309 { op1(LispObject arg1)310 public LispObject op1(LispObject arg1) throws Exception 311 { 312 return op2(arg1, null); 313 } op2(LispObject arg1, LispObject arg2)314 public LispObject op2(LispObject arg1, LispObject arg2) throws Exception 315 { 316 for (;;) 317 { if (arg1.atom) return arg1; 318 if (!(arg1.car instanceof Symbol)) return arg1; 319 Symbol f = (Symbol)arg1.car; 320 LispFunction fn = f.fn; 321 if (!(fn instanceof Macro)) return arg1; 322 // At last - here I have a macro that I can expand 323 arg1 = fn.op1(arg1); 324 } 325 } 326 } 327 328 class Macroexpand_1Fn extends BuiltinFunction 329 { op1(LispObject arg1)330 public LispObject op1(LispObject arg1) throws Exception 331 { 332 return op2(arg1, null); 333 } op2(LispObject arg1, LispObject arg2)334 public LispObject op2(LispObject arg1, LispObject arg2) throws Exception 335 { 336 if (arg1.atom) return arg1; 337 if (!(arg1.car instanceof Symbol)) return arg1; 338 Symbol f = (Symbol)arg1.car; 339 LispFunction fn = f.fn; 340 if (!(fn instanceof Macro)) return arg1; 341 // At last - here I have a macro that I can expand 342 return fn.op1(arg1); 343 } 344 } 345 346 class Make_bpsFn extends BuiltinFunction 347 { op1(LispObject arg1)348 public LispObject op1(LispObject arg1) throws Exception 349 { 350 int n = ((LispSmallInteger)arg1).value; 351 return new Bytecode(n); 352 } 353 } 354 355 class Make_function_streamFn extends BuiltinFunction 356 { op1(LispObject arg1)357 public LispObject op1(LispObject arg1) throws Exception 358 { 359 return error(name + " not yet implemented"); 360 } 361 } 362 363 class Make_globalFn extends BuiltinFunction 364 { op1(LispObject arg1)365 public LispObject op1(LispObject arg1) throws ResourceException 366 { 367 Symbol s = (Symbol)arg1; 368 Fns.put(s, Jlisp.lit[Lit.global], Jlisp.lispTrue); 369 if (s.car/*value*/ == Jlisp.lit[Lit.undefined]) s.car/*value*/ = Jlisp.nil; 370 return Jlisp.nil; 371 } 372 } 373 374 class Make_nativeFn extends BuiltinFunction 375 { op1(LispObject arg1)376 public LispObject op1(LispObject arg1) throws Exception 377 { 378 return error(name + " not yet implemented"); 379 } 380 } 381 382 class Make_random_stateFn extends BuiltinFunction 383 { op1(LispObject arg1)384 public LispObject op1(LispObject arg1) throws Exception 385 { 386 return error(name + " not yet implemented"); 387 } 388 } 389 390 class Make_simple_stringFn extends BuiltinFunction 391 { op1(LispObject arg1)392 public LispObject op1(LispObject arg1) throws Exception 393 { 394 int n = ((LispSmallInteger)arg1).value; 395 char [] c = new char[n]; 396 for (int i=0; i<n; i++) c[i] = (char)0; 397 return new LispString(new String(c)); 398 } 399 } 400 401 class Make_specialFn extends BuiltinFunction 402 { op1(LispObject arg1)403 public LispObject op1(LispObject arg1) throws ResourceException 404 { 405 Symbol s = (Symbol)arg1; 406 Fns.put(s, Jlisp.lit[Lit.special], Jlisp.lispTrue); 407 if (s.car/*value*/ == Jlisp.lit[Lit.undefined]) s.car/*value*/ = Jlisp.nil; 408 return Jlisp.nil; 409 } 410 } 411 412 class MapFn extends BuiltinFunction 413 { op1(LispObject arg1)414 public LispObject op1(LispObject arg1) throws Exception 415 { 416 return error(name + " not yet implemented"); 417 } 418 } 419 420 class MapcFn extends BuiltinFunction 421 { op1(LispObject arg1)422 public LispObject op1(LispObject arg1) throws Exception 423 { 424 return error(name + " not yet implemented"); 425 } 426 } 427 428 class MapcanFn extends BuiltinFunction 429 { op1(LispObject arg1)430 public LispObject op1(LispObject arg1) throws Exception 431 { 432 return error(name + " not yet implemented"); 433 } 434 } 435 436 class MapcarFn extends BuiltinFunction 437 { op1(LispObject arg1)438 public LispObject op1(LispObject arg1) throws Exception 439 { 440 return error(name + " not yet implemented"); 441 } 442 } 443 444 class MapconFn extends BuiltinFunction 445 { op1(LispObject arg1)446 public LispObject op1(LispObject arg1) throws Exception 447 { 448 return error(name + " not yet implemented"); 449 } 450 } 451 452 class MaphashFn extends BuiltinFunction 453 { op1(LispObject arg1)454 public LispObject op1(LispObject arg1) throws Exception 455 { 456 return error(name + " not yet implemented"); 457 } 458 } 459 460 class MaplistFn extends BuiltinFunction 461 { op1(LispObject arg1)462 public LispObject op1(LispObject arg1) throws Exception 463 { 464 return error(name + " not yet implemented"); 465 } 466 } 467 468 class MapstoreFn extends BuiltinFunction 469 { op1(LispObject arg1)470 public LispObject op1(LispObject arg1) throws Exception 471 { 472 Jlisp.println(); 473 Jlisp.println("*** MAPSTORE ***"); 474 return Jlisp.nil; 475 } 476 } 477 478 class Md5Fn extends BuiltinFunction 479 { op1(LispObject arg1)480 public LispObject op1(LispObject arg1) throws Exception 481 { 482 LispStream f = new LispDigester(); 483 LispObject save = Jlisp.lit[Lit.std_output].car/*value*/; 484 try 485 { Jlisp.lit[Lit.std_output].car/*value*/ = f; 486 arg1.print(LispObject.noLineBreak+LispObject.printEscape); 487 } 488 finally 489 { Jlisp.lit[Lit.std_output].car/*value*/ = save; 490 } 491 byte [] res = f.md.digest(); 492 return LispInteger.valueOf(new BigInteger(res)); 493 } 494 } 495 496 class Md60Fn extends BuiltinFunction 497 { op1(LispObject arg1)498 public LispObject op1(LispObject arg1) throws Exception 499 { 500 LispStream f = new LispDigester(); 501 LispObject save = Jlisp.lit[Lit.std_output].car/*value*/; 502 try 503 { Jlisp.lit[Lit.std_output].car/*value*/ = f; 504 arg1.print(LispObject.noLineBreak+LispObject.printEscape); 505 } 506 finally 507 { Jlisp.lit[Lit.std_output].car/*value*/ = save; 508 } 509 byte [] res = f.md.digest(); 510 return LispInteger.valueOf(new BigInteger(res).shiftRight(68)); 511 } 512 } 513 514 515 class MemberFn extends BuiltinFunction 516 { op2(LispObject arg1, LispObject arg2)517 public LispObject op2(LispObject arg1, LispObject arg2) 518 { 519 while (!arg2.atom) 520 { if (arg1.lispequals(arg2.car)) return arg2; 521 arg2 = arg2.cdr; 522 } 523 return Jlisp.nil; 524 } 525 } 526 527 class MemberStarStarFn extends BuiltinFunction 528 { op2(LispObject arg1, LispObject arg2)529 public LispObject op2(LispObject arg1, LispObject arg2) 530 { 531 while (!arg2.atom) 532 { if (arg1.lispequals(arg2.car)) return arg2; 533 arg2 = arg2.cdr; 534 } 535 return Jlisp.nil; 536 } 537 } 538 539 class MemqFn extends BuiltinFunction 540 { op2(LispObject arg1, LispObject arg2)541 public LispObject op2(LispObject arg1, LispObject arg2) throws Exception 542 { 543 while (!arg2.atom) 544 { if (arg1 instanceof LispNumber) // @@@ 545 { if (arg1.lispequals(arg2.car)) return arg2; // @@@ 546 } // @@@ 547 else if (arg1 == arg2.car) return arg2; 548 arg2 = arg2.cdr; 549 } 550 return Jlisp.nil; 551 } 552 } 553 554 class MkevectFn extends BuiltinFunction 555 { op1(LispObject arg1)556 public LispObject op1(LispObject arg1) throws Exception 557 { 558 return error(name + " not yet implemented"); 559 } 560 } 561 562 class Mkfvect32Fn extends BuiltinFunction 563 { op1(LispObject arg1)564 public LispObject op1(LispObject arg1) throws Exception 565 { 566 return error(name + " not yet implemented"); 567 } 568 } 569 570 class Mkfvect64Fn extends BuiltinFunction 571 { op1(LispObject arg1)572 public LispObject op1(LispObject arg1) throws Exception 573 { 574 return error(name + " not yet implemented"); 575 } 576 } 577 578 class MkhashFn extends BuiltinFunction 579 { 580 // (MKHASH size flavour growth-ratio) 581 // size is initial table size 582 // flavour: 0 EQ 583 // 1 EQL 584 // 2 EQUAL 585 // 3 EQUALS 586 // 4 EQUALP 587 // ratio: amount to expand by as table gets full 588 // 589 // In this Java version I will ignore the first and third args, 590 // and only support EQ and EQUAL tables! Note that an EQ table 591 // will generally re-hash itself if serialized... 592 opn(LispObject [] args)593 public LispObject opn(LispObject [] args) throws Exception 594 { 595 if (args.length != 3) 596 return error("mkhash called with " + args.length + 597 "args when 3 expected"); 598 int n = ((LispSmallInteger)args[1]).value; 599 HashMap h; 600 if (n == 0) h = new HashMap(); 601 else h = new LispEqualHash(); 602 return new LispHash(h, n); 603 } 604 } 605 606 class MkquoteFn extends BuiltinFunction 607 { op1(LispObject arg1)608 public LispObject op1(LispObject arg1) throws Exception 609 { 610 return new Cons(Jlisp.lit[Lit.quote], 611 new Cons(arg1, Jlisp.nil)); 612 } 613 } 614 615 class MkvectFn extends BuiltinFunction 616 { op1(LispObject arg1)617 public LispObject op1(LispObject arg1) 618 { 619 int n = ((LispSmallInteger)arg1).value; 620 return new LispVector(n+1); // Hah - index values from 0 to n 621 } 622 } 623 624 class Mkvect16Fn extends BuiltinFunction 625 { op1(LispObject arg1)626 public LispObject op1(LispObject arg1) throws Exception 627 { 628 return error(name + " not yet implemented"); 629 } 630 } 631 632 class Mkvect32Fn extends BuiltinFunction 633 { op1(LispObject arg1)634 public LispObject op1(LispObject arg1) throws Exception 635 { 636 return error(name + " not yet implemented"); 637 } 638 } 639 640 class Mkvect8Fn extends BuiltinFunction 641 { op1(LispObject arg1)642 public LispObject op1(LispObject arg1) throws Exception 643 { 644 return error(name + " not yet implemented"); 645 } 646 } 647 648 class MkxvectFn extends BuiltinFunction 649 { op1(LispObject arg1)650 public LispObject op1(LispObject arg1) throws Exception 651 { 652 return error(name + " not yet implemented"); 653 } 654 } 655 656 class ModulepFn extends BuiltinFunction 657 { op1(LispObject arg1)658 public LispObject op1(LispObject arg1) throws Exception 659 { 660 String s; 661 if (arg1 instanceof Symbol) 662 { ((Symbol)arg1).completeName(); 663 s = ((Symbol)arg1).pname; 664 } 665 else if (arg1 instanceof LispString) s = ((LispString)arg1).string; 666 else return error("illegal arg to modulep", arg1); 667 s = s + ".fasl"; 668 for (int i=0; i<Jlisp.imageCount; i++) 669 { arg1 = Jlisp.images[i].modulep(s); 670 if (arg1 != Jlisp.nil) return arg1; 671 } 672 return Jlisp.nil; 673 } 674 } 675 676 class Native_addressFn extends BuiltinFunction 677 { op1(LispObject arg1)678 public LispObject op1(LispObject arg1) throws Exception 679 { 680 return error(name + " not yet implemented"); 681 } 682 } 683 684 class Native_getvFn extends BuiltinFunction 685 { op1(LispObject arg1)686 public LispObject op1(LispObject arg1) throws Exception 687 { 688 return error(name + " not yet implemented"); 689 } 690 } 691 692 class Native_putvFn extends BuiltinFunction 693 { op1(LispObject arg1)694 public LispObject op1(LispObject arg1) throws Exception 695 { 696 return error(name + " not yet implemented"); 697 } 698 } 699 700 class Native_typeFn extends BuiltinFunction 701 { op1(LispObject arg1)702 public LispObject op1(LispObject arg1) throws Exception 703 { 704 return error(name + " not yet implemented"); 705 } 706 } 707 708 class NconcFn extends BuiltinFunction 709 { op2(LispObject arg1, LispObject arg2)710 public LispObject op2(LispObject arg1, LispObject arg2) throws Exception 711 { 712 if (arg1.atom) return arg2; 713 LispObject r = arg1; 714 LispObject prev = null; 715 while (!arg1.atom) 716 { prev = arg1; 717 arg1 = prev.cdr; 718 } 719 prev.cdr = arg2; 720 return r; 721 } 722 } 723 724 class NconsFn extends BuiltinFunction 725 { op1(LispObject arg1)726 public LispObject op1(LispObject arg1) throws ResourceException 727 { 728 return new Cons(arg1, Jlisp.nil); 729 } 730 } 731 732 class NeqFn extends BuiltinFunction 733 { op2(LispObject arg1, LispObject arg2)734 public LispObject op2(LispObject arg1, LispObject arg2) 735 { 736 if (arg1 == arg2) return Jlisp.nil; 737 return arg1.lispequals(arg2) ? Jlisp.nil : 738 Jlisp.lispTrue; 739 } 740 } 741 742 class Noisy_setqFn extends BuiltinFunction 743 { op1(LispObject arg1)744 public LispObject op1(LispObject arg1) throws Exception 745 { 746 return error(name + " not yet implemented"); 747 } 748 } 749 750 class NotFn extends BuiltinFunction 751 { op1(LispObject arg1)752 public LispObject op1(LispObject arg1) 753 { 754 return arg1 == Jlisp.nil ? 755 Jlisp.lispTrue : 756 Jlisp.nil; 757 } 758 } 759 760 class NullFn extends BuiltinFunction 761 { op1(LispObject arg1)762 public LispObject op1(LispObject arg1) 763 { 764 return arg1 == Jlisp.nil ? 765 Jlisp.lispTrue : 766 Jlisp.nil; 767 } 768 } 769 770 class OblistFn extends BuiltinFunction 771 { op0()772 public LispObject op0() throws ResourceException 773 { 774 // Note that this implementation pushes out the object list with 775 // items in a randomish order. CSL sorted it which was nice - to do that 776 // here I would have to implement a sorting function, and as present that 777 // does not seem my highest priority. 778 LispObject r = Jlisp.nil; 779 for (int i=0; i<Jlisp.oblistSize; i++) 780 { Symbol w = Jlisp.oblist[i]; 781 if (w != null) 782 { if (w.car/*value*/ != Jlisp.lit[Lit.undefined] || 783 w.cdr/*plist*/ != Jlisp.nil || 784 w.special != null || 785 !(w.fn instanceof Undefined)) 786 r = new Cons(w, r); 787 } 788 } 789 return r; 790 } 791 } 792 793 class Oem_supervisorFn extends BuiltinFunction 794 { op1(LispObject arg1)795 public LispObject op1(LispObject arg1) throws Exception 796 { 797 return error(name + " not yet implemented"); 798 } 799 } 800 801 class OpenFn extends BuiltinFunction 802 { op2(LispObject arg1, LispObject arg2)803 public LispObject op2(LispObject arg1, LispObject arg2) throws Exception 804 { 805 if (!(arg1 instanceof LispString)) 806 return error("argument 1 to open must be a string"); 807 String name = ((LispString)arg1).string; 808 if (arg2 == Jlisp.lit[Lit.input]) 809 { LispObject r = Jlisp.nil; 810 try 811 { r = new LispStream( 812 name, 813 new BufferedReader( 814 new FileReader(LispStream.nameConvert(name))), 815 false, true); 816 } 817 catch (FileNotFoundException e) 818 { return error("File " + name + " not found"); 819 } 820 return r; 821 } 822 else if (arg2 == Jlisp.lit[Lit.output]) 823 { LispObject r = Jlisp.nil; 824 try 825 { r = new LispOutputStream(name); 826 } 827 catch (IOException e) 828 { return error("File " + name + " can not be opened for output"); 829 } 830 return r; 831 } 832 else if (arg2 == Jlisp.lit[Lit.append]) 833 { LispObject r = Jlisp.nil; 834 try 835 { r = new LispOutputStream(name, true); 836 } 837 catch (IOException e) 838 { return error("File " + name + " can not be opened for output"); 839 } 840 return r; 841 } 842 else return error( 843 "argument 2 to open should be input, output or append"); 844 } 845 } 846 847 848 // The system-coded primitive function ~OPEN opens a file, and takes a second 849 // argument that shows what options are wanted. See extracts from the CSL 850 // file "print.c" (included just below this comment) for an explanation 851 // of the bits. 852 // 853 // This stuff is here so I can be almost ridiculously compatible with CSL 854 // since that makes it easier to share files with that world... 855 // 856 //(de open (a b) 857 // (cond 858 // ((eq b 'input) (!~open a (plus 1 64))) % if-does-not-exist error 859 // ((eq b 'output) (!~open a (plus 2 20 32))) % if-does-not-exist create, 860 // % if-exists new-version 861 // ((eq b 'append) (!~open a (plus 2 8 32))) % if-exists append 862 // (t (error "bad direction ~A in open" b)))) 863 // 864 //(de binopen (a b) 865 // (cond 866 // ((eq b 'input) (!~open a (plus 1 64 128))) 867 // ((eq b 'output) (!~open a (plus 2 20 32 128))) 868 // ((eq b 'append) (!~open a (plus 2 8 32 128))) 869 // (t (error "bad direction ~A in binopen" b)))) 870 // 871 //(de pipe!-open (c d) 872 // (cond 873 // ((eq d 'input) (!~open c (plus 1 256))) 874 // ((eq d 'output) (!~open c (plus 2 256))) 875 // (t (error "bad direction ~A in pipe-open" d)))) 876 // 877 878 879 // 880 ///* 881 // * The Common Lisp keywords for OPEN are a horrid mess. I arrange to decode 882 // * the syntax of the keywords in a Lisp-coded wrapper function, and in that 883 // * code I will also fill in default values for any that needs same. I then 884 // * pack all the information into a single integer, which has several 885 // * sub-fields 886 // * 887 // * x x xx xxx 00 direction PROBE 888 // * x x xx xxx 01 INPUT 889 // * x x xx xxx 10 OUTPUT 890 // * x x xx xxx 11 IO 891 // * 892 // * x x xx 000 xx if-exists NIL 893 // * x x xx 001 xx overwrite 894 // * x x xx 010 xx append 895 // * x x xx 011 xx rename 896 // * x x xx 100 xx error 897 // * x x xx 101 xx (new-version) 898 // * x x xx 110 xx (supersede) 899 // * x x xx 111 xx (rename-and-delete) 900 // * 901 // * x x 00 xxx xx if-does-not-exist NIL 902 // * x x 01 xxx xx create 903 // * x x 10 xxx xx error 904 // * 905 // * x 0 xx xxx xx regular text file 906 // * x 1 xx xxx xx open for binary access 907 // * 908 // * 0 x xx xxx xx regular file 909 // * 1 x xx xxx xx open as a pipe 910 // */ 911 // 912 //#define DIRECTION_MASK 0x3 913 //#define DIRECTION_PROBE 0x0 914 //#define DIRECTION_INPUT 0x1 915 //#define DIRECTION_OUTPUT 0x2 916 //#define DIRECTION_IO 0x3 917 //#define IF_EXISTS_MASK 0x1c 918 //#define IF_EXISTS_NIL 0x00 919 //#define IF_EXISTS_OVERWRITE 0x04 920 //#define IF_EXISTS_APPEND 0x08 921 //#define IF_EXISTS_RENAME 0x0c 922 //#define IF_EXISTS_ERROR 0x10 923 //#define IF_EXISTS_NEW_VERSION 0x14 924 //#define IF_EXISTS_SUPERSEDE 0x18 925 //#define IF_EXISTS_RENAME_AND_DELETE 0x1c 926 //#define IF_MISSING_MASK 0x60 927 //#define IF_MISSING_NIL 0x00 928 //#define IF_MISSING_CREATE 0x20 929 //#define IF_MISSING_ERROR 0x40 930 //#define OPEN_BINARY 0x80 931 //#define OPEN_PIPE 0x100 932 933 class InternalOpenFn extends BuiltinFunction 934 { op2(LispObject arg1, LispObject arg2)935 public LispObject op2(LispObject arg1, LispObject arg2) throws Exception 936 { 937 if (!(arg1 instanceof LispString)) 938 return error("argument 1 to ~open must be a string"); 939 String name = ((LispString)arg1).string; 940 int bits = ((LispSmallInteger)arg2).value; 941 if ((bits & 0x100) != 0) return openPipe(name, bits); 942 String localName = LispStream.nameConvert(name); 943 File f = new File(localName); 944 boolean x = f.exists(); 945 LispObject r; 946 switch (bits & 3) 947 { 948 case 0: // probe 949 if (x) return Jlisp.lispTrue; 950 else return Jlisp.nil; 951 case 1: // read 952 if (!x) 953 { switch (bits & 0x60) 954 { 955 case 0x00: return Jlisp.nil; 956 case 0x40: return Jlisp.error("File does not exist: " + name); 957 default: return Jlisp.error("File open mode unknown " + 958 Integer.toHexString(bits)); 959 } 960 } 961 r = Jlisp.nil; 962 try 963 { r = new LispStream( 964 name, 965 new BufferedReader( 966 new FileReader(f)), 967 false, true); 968 } 969 catch (FileNotFoundException e) // should not happen! 970 { return error("File " + name + " not found"); 971 } 972 return r; 973 case 2: // write 974 r = Jlisp.nil; 975 try 976 { if (x) 977 { switch (bits & 0x1c) 978 { 979 case 0x00: return Jlisp.nil; 980 case 0x14: // new version: treat as overwrite... 981 case 0x04: return new LispOutputStream(f); 982 // the "append" option seems to have to be opened based on a String not a File 983 case 0x08: return new LispOutputStream(localName, true); 984 case 0x10: return error("File already exists: " + name); 985 default: return error("Unsupported file open mode: " + 986 Integer.toHexString(bits)); 987 } 988 } 989 else r = new LispOutputStream(f); 990 } 991 catch (IOException e) 992 { return Jlisp.nil; 993 } 994 return r; 995 case 3: // input and output 996 return error("simultaneous input+output mode files not supported"); 997 } 998 return Jlisp.nil; 999 } 1000 openPipe(String name, int bits)1001 public LispObject openPipe(String name, int bits) throws Exception 1002 { 1003 return error("pipes not supported by Java, it seems?"); 1004 } 1005 1006 } 1007 1008 class Open_libraryFn extends BuiltinFunction 1009 { op1(LispObject arg1)1010 public LispObject op1(LispObject arg1) throws Exception 1011 { 1012 return error(name + " not yet implemented"); 1013 } 1014 } 1015 1016 class Open_urlFn extends BuiltinFunction 1017 { op1(LispObject arg1)1018 public LispObject op1(LispObject arg1) throws Exception 1019 { 1020 return error(name + " not yet implemented"); 1021 } 1022 } 1023 1024 class OrderpFn extends BuiltinFunction 1025 { 1026 // symbolic procedure ordp(u,v); 1027 // if null u then null v 1028 // else if null v then t 1029 // else if vectorp u then if vectorp v then ordpv(u,v) else atom v 1030 // else if atom u 1031 // then if atom v 1032 // then if numberp u then numberp v and not u<v 1033 // else if idp v then orderp(u,v) 1034 // else numberp v 1035 // else nil 1036 // else if atom v then t 1037 // else if car u=car v then ordp(cdr u,cdr v) 1038 // else if flagp(car u,'noncom) 1039 // then if flagp(car v,'noncom) then ordp(car u,car v) else t 1040 // else if flagp(car v,'noncom) then nil 1041 // else ordp(car u,car v); 1042 // 1043 op2(LispObject u, LispObject v)1044 public LispObject op2(LispObject u, LispObject v) throws Exception 1045 { if (ordp(u,v)) return Jlisp.lispTrue; 1046 else return Jlisp.nil; 1047 } 1048 ordp(LispObject u, LispObject v)1049 boolean ordp(LispObject u, LispObject v) throws Exception 1050 { 1051 if (u == Jlisp.nil) return (v == Jlisp.nil); 1052 else if (v == Jlisp.nil) return true; 1053 else if (u instanceof LispVector) 1054 { if (v instanceof LispVector) 1055 return ordv((LispVector)u, (LispVector)v); 1056 else return v.atom; 1057 } 1058 else if (u.atom) 1059 { if (v.atom) 1060 { if (u instanceof LispNumber) 1061 { if (!(v instanceof LispNumber)) return false; 1062 return (Fns.lessp(u, v) == Jlisp.nil); 1063 } 1064 else if (v instanceof Symbol) 1065 { if (!(u instanceof Symbol)) return false; 1066 ((Symbol)u).completeName(); 1067 ((Symbol)v).completeName(); 1068 return ((Symbol)u).pname.compareTo( 1069 ((Symbol)v).pname) <= 0; 1070 } 1071 else return (v instanceof LispNumber); 1072 } 1073 else return false; 1074 } 1075 else if (v.atom) return true; 1076 LispObject cu = u, cv = v; 1077 LispObject caru = cu.car, carv = cv.car; 1078 if (caru.lispequals(carv)) 1079 return ordp(cu.cdr, cv.cdr); 1080 else if (Fns.get(caru, Jlisp.lit[Lit.noncom]) != 1081 Jlisp.nil) 1082 { if (Fns.get(carv, Jlisp.lit[Lit.noncom]) != 1083 Jlisp.nil) 1084 return ordp(caru, carv); 1085 else return true; 1086 } 1087 else if (Fns.get(carv, Jlisp.lit[Lit.noncom]) != 1088 Jlisp.nil) 1089 return false; 1090 else return ordp(caru, carv); 1091 } 1092 ordv(LispVector u, LispVector v)1093 boolean ordv(LispVector u, LispVector v) 1094 { 1095 return false; 1096 } 1097 } 1098 1099 class Output_libraryFn extends BuiltinFunction 1100 { op1(LispObject arg1)1101 public LispObject op1(LispObject arg1) throws Exception 1102 { 1103 return error(name + " not yet implemented"); 1104 } 1105 } 1106 1107 class PagelengthFn extends BuiltinFunction 1108 { op1(LispObject arg1)1109 public LispObject op1(LispObject arg1) throws Exception 1110 { 1111 return error(name + " not yet implemented"); 1112 } 1113 } 1114 1115 class PairFn extends BuiltinFunction 1116 { op2(LispObject arg1, LispObject arg2)1117 public LispObject op2(LispObject arg1, LispObject arg2) throws Exception 1118 { 1119 if (!arg1.atom) 1120 { if (!arg2.atom) 1121 { return new Cons( 1122 new Cons(arg1.car, arg2.car), 1123 op2(arg1.cdr, arg2.cdr)); 1124 } 1125 else return error("arg2 to pair is too short"); 1126 } 1127 else if (!arg2.atom) 1128 return error("arg2 to pair is too long"); 1129 else return Jlisp.nil; 1130 } 1131 } 1132 1133 class PairpFn extends BuiltinFunction 1134 { op1(LispObject arg1)1135 public LispObject op1(LispObject arg1) throws Exception 1136 { return arg1.atom ? Jlisp.nil : 1137 Jlisp.lispTrue; 1138 } 1139 } 1140 1141 class PeekchFn extends BuiltinFunction 1142 { op1(LispObject arg1)1143 public LispObject op1(LispObject arg1) throws Exception 1144 { 1145 return error(name + " not yet implemented"); 1146 } 1147 } 1148 1149 class Pipe_openFn extends BuiltinFunction 1150 { op1(LispObject arg1)1151 public LispObject op1(LispObject arg1) throws Exception 1152 { 1153 return error(name + " not yet implemented"); 1154 } 1155 } 1156 1157 class PlistFn extends BuiltinFunction 1158 { op1(LispObject arg1)1159 public LispObject op1(LispObject arg1) 1160 { 1161 return ((Symbol)arg1).cdr/*plist*/; 1162 } 1163 } 1164 1165 class PosnFn extends BuiltinFunction 1166 { op0()1167 public LispObject op0() throws Exception 1168 { 1169 int n = ((LispStream) 1170 Jlisp.lit[Lit.std_output].car/*value*/).column; 1171 return LispInteger.valueOf(n); 1172 } 1173 } 1174 1175 class RestartFn extends BuiltinFunction 1176 { op1(LispObject arg1)1177 public LispObject op1(LispObject arg1) throws Exception 1178 { 1179 Jlisp.backtrace = false; 1180 throw new ProgEvent(ProgEvent.RESTART, arg1, "restart"); 1181 } op2(LispObject arg1, LispObject arg2)1182 public LispObject op2(LispObject arg1, LispObject arg2) throws Exception 1183 { 1184 Jlisp.backtrace = false; 1185 throw new ProgEvent(ProgEvent.RESTART, arg1, arg2, "restart"); 1186 } 1187 } 1188 1189 // (preserve [restartfn [initmsg]]) 1190 // dumps all state to a file specifed 1191 // as "-o xxx.img" on the initial command-line. 1192 1193 class PreserveFn extends BuiltinFunction 1194 { op0()1195 public LispObject op0() throws Exception 1196 { 1197 return op2(Jlisp.nil, Jlisp.nil); 1198 } 1199 op1(LispObject arg1)1200 public LispObject op1(LispObject arg1) throws Exception 1201 { 1202 return op2(arg1, Jlisp.nil); 1203 } 1204 op2(LispObject arg1, LispObject arg2)1205 public LispObject op2(LispObject arg1, LispObject arg2) throws Exception 1206 { 1207 // Following the tradition from CSL when the user calls PRESERVE the 1208 // system stops. This makes more sense than one might have thought since 1209 // in the process of unwinding (via the ProgEvent you see here) all fluid 1210 // variables are put back to their top level values. If I checkpointed 1211 // the system more directly various local bindings might be captured, and 1212 // I think that would be undesirable. 1213 if (Jlisp.outputImagePos < 0) 1214 return Jlisp.error("No output image available"); 1215 Jlisp.backtrace = false; 1216 throw new ProgEvent(ProgEvent.PRESERVE, 1217 new Cons(arg1, arg2), 1218 "preserve"); 1219 } 1220 } 1221 1222 class SaveObjectFn extends BuiltinFunction 1223 { 1224 op2(LispObject arg1, LispObject arg2)1225 public LispObject op2(LispObject arg1, LispObject arg2) throws Exception 1226 { 1227 String name = ((LispString)arg1).string; 1228 GZIPOutputStream dump = null; 1229 try 1230 { dump = new GZIPOutputStream( 1231 new BufferedOutputStream( 1232 new FileOutputStream(name), 1233 32768)); 1234 Jlisp.dumpTree(arg2, dump); 1235 } 1236 catch (IOException e) 1237 { Jlisp.errprintln("IO error on dump file: " + e.getMessage()); 1238 } 1239 finally 1240 { if (dump != null) dump.close(); 1241 } 1242 return Jlisp.nil; 1243 } 1244 } 1245 1246 class RestoreObjectFn extends BuiltinFunction 1247 { 1248 op1(LispObject arg1)1249 public LispObject op1(LispObject arg1) throws Exception 1250 { 1251 return op2(arg1, LispInteger.valueOf(1)); 1252 } 1253 op2(LispObject arg1, LispObject arg2)1254 public LispObject op2(LispObject arg1, LispObject arg2) throws Exception 1255 { 1256 String name = ((LispString)arg1).string; 1257 // read item number n from the file concerned. Used to debug! 1258 int n = ((LispSmallInteger)arg2).value; 1259 LispObject r = Jlisp.nil; 1260 Jlisp.idump = null; 1261 try 1262 { GZIPInputStream dump = 1263 new GZIPInputStream( 1264 new BufferedInputStream( 1265 new FileInputStream(name), 1266 32768)); 1267 Jlisp.idump = dump; 1268 Jlisp.preRestore(); 1269 Jlisp.descendSymbols = false; 1270 for (int i=0; i<n; i++) 1271 r = Jlisp.readObject(); 1272 } 1273 catch (IOException e) 1274 { Jlisp.errprintln("IO error on dump file: " + e.getMessage()); 1275 } 1276 finally 1277 { if (Jlisp.idump != null) Jlisp.idump.close(); 1278 Jlisp.postRestore(); 1279 } 1280 if (r == null) return new LispString("<null>"); 1281 else return r; 1282 } 1283 } 1284 1285 class PrinFn extends BuiltinFunction 1286 { op1(LispObject arg1)1287 public LispObject op1(LispObject arg1) throws ResourceException 1288 { 1289 arg1.print(LispObject.printEscape); 1290 return arg1; 1291 } 1292 } 1293 1294 class Prin1Fn extends BuiltinFunction 1295 { op1(LispObject arg1)1296 public LispObject op1(LispObject arg1) throws ResourceException 1297 { 1298 arg1.print(LispObject.printEscape); 1299 return arg1; 1300 } 1301 } 1302 1303 class Prin2Fn extends BuiltinFunction 1304 { op1(LispObject arg1)1305 public LispObject op1(LispObject arg1) throws ResourceException 1306 { 1307 arg1.print(0); 1308 return arg1; 1309 } 1310 } 1311 1312 class Prin2aFn extends BuiltinFunction 1313 { op1(LispObject arg1)1314 public LispObject op1(LispObject arg1) throws ResourceException 1315 { 1316 arg1.print(LispObject.noLineBreak); 1317 return arg1; 1318 } 1319 } 1320 1321 class PrinbinaryFn extends BuiltinFunction 1322 { op1(LispObject arg1)1323 public LispObject op1(LispObject arg1) throws ResourceException 1324 { 1325 arg1.print(LispObject.printBinary); 1326 return arg1; 1327 } 1328 } 1329 1330 class PrincFn extends BuiltinFunction 1331 { op1(LispObject arg1)1332 public LispObject op1(LispObject arg1) throws ResourceException 1333 { 1334 arg1.print(); 1335 return arg1; 1336 } 1337 } 1338 1339 class Princ_downcaseFn extends BuiltinFunction 1340 { op1(LispObject arg1)1341 public LispObject op1(LispObject arg1) throws ResourceException 1342 { 1343 arg1.print(LispObject.printLower); 1344 return arg1; 1345 } 1346 } 1347 1348 class Princ_upcaseFn extends BuiltinFunction 1349 { op1(LispObject arg1)1350 public LispObject op1(LispObject arg1) throws ResourceException 1351 { 1352 arg1.print(LispObject.printUpper); 1353 return arg1; 1354 } 1355 } 1356 1357 class PrinhexFn extends BuiltinFunction 1358 { op1(LispObject arg1)1359 public LispObject op1(LispObject arg1) throws ResourceException 1360 { 1361 arg1.print(LispObject.printHex); 1362 return arg1; 1363 } 1364 } 1365 1366 class PrinoctalFn extends BuiltinFunction 1367 { op1(LispObject arg1)1368 public LispObject op1(LispObject arg1) throws ResourceException 1369 { 1370 arg1.print(LispObject.printOctal); 1371 return arg1; 1372 } 1373 } 1374 1375 class PrintFn extends BuiltinFunction 1376 { op1(LispObject arg1)1377 public LispObject op1(LispObject arg1) throws ResourceException 1378 { 1379 arg1.print(LispObject.printEscape); 1380 Jlisp.println(); 1381 return arg1; 1382 } 1383 } 1384 1385 class PrintcFn extends BuiltinFunction 1386 { op1(LispObject arg1)1387 public LispObject op1(LispObject arg1) throws ResourceException 1388 { 1389 arg1.print(); 1390 Jlisp.println(); 1391 return arg1; 1392 } 1393 } 1394 1395 class PrintpromptFn extends BuiltinFunction 1396 { op1(LispObject arg1)1397 public LispObject op1(LispObject arg1) throws Exception 1398 { 1399 return error(name + " not yet implemented"); 1400 } 1401 } 1402 1403 class Prog1Fn extends BuiltinFunction 1404 { op0()1405 public LispObject op0() 1406 { 1407 return Jlisp.nil; 1408 } op1(LispObject arg1)1409 public LispObject op1(LispObject arg1) 1410 { 1411 return arg1; 1412 } op2(LispObject arg1, LispObject arg2)1413 public LispObject op2(LispObject arg1, LispObject arg2) 1414 { 1415 return arg1; 1416 } opn(LispObject [] args)1417 public LispObject opn(LispObject [] args) 1418 { 1419 return args[0]; 1420 } 1421 } 1422 1423 class Prog2Fn extends BuiltinFunction 1424 { op0()1425 public LispObject op0() 1426 { 1427 return Jlisp.nil; 1428 } op1(LispObject arg1)1429 public LispObject op1(LispObject arg1) 1430 { 1431 return Jlisp.nil; 1432 } op2(LispObject arg1, LispObject arg2)1433 public LispObject op2(LispObject arg1, LispObject arg2) 1434 { 1435 return arg2; 1436 } opn(LispObject [] args)1437 public LispObject opn(LispObject [] args) 1438 { 1439 return args[1]; 1440 } 1441 } 1442 1443 class PrognFn extends BuiltinFunction 1444 { op0()1445 public LispObject op0() 1446 { 1447 return Jlisp.nil; 1448 } 1449 op1(LispObject arg1)1450 public LispObject op1(LispObject arg1) 1451 { 1452 return arg1; 1453 } op2(LispObject arg1, LispObject arg2)1454 public LispObject op2(LispObject arg1, LispObject arg2) 1455 { 1456 return arg2; 1457 } opn(LispObject [] args)1458 public LispObject opn(LispObject [] args) 1459 { 1460 return args[args.length-1]; 1461 } 1462 1463 } 1464 1465 class PutFn extends BuiltinFunction 1466 { opn(LispObject [] args)1467 public LispObject opn(LispObject [] args) throws Exception 1468 { 1469 if (args.length != 3) 1470 return error("put called with " + args.length + 1471 "args when 3 expected"); 1472 return Fns.put((Symbol)args[0], args[1], args[2]); 1473 } 1474 } 1475 1476 class PuthashFn extends BuiltinFunction 1477 { op2(LispObject key, LispObject value)1478 public LispObject op2(LispObject key, LispObject value) 1479 { 1480 ((LispHash)Jlisp.lit[Lit.hashtab]).hash.put(key, value); 1481 return value; 1482 } opn(LispObject [] args)1483 public LispObject opn(LispObject [] args) throws Exception 1484 { 1485 if (args.length != 3) 1486 return error("puthash called with " + args.length + 1487 "args when 2 or 3 expected"); 1488 LispObject key = args[0]; 1489 LispHash h = (LispHash)args[1]; 1490 LispObject value = args[2]; 1491 h.hash.put(key, value); 1492 return value; 1493 } 1494 } 1495 1496 class PutvFn extends BuiltinFunction 1497 { opn(LispObject [] args)1498 public LispObject opn(LispObject [] args) throws Exception 1499 { 1500 if (args.length != 3) 1501 return error("putv called with " + args.length + 1502 "args when 3 expected"); 1503 LispVector v = (LispVector)args[0]; 1504 LispSmallInteger n = (LispSmallInteger)args[1]; 1505 int i = n.value; 1506 v.vec[i] = args[2]; 1507 return args[2]; 1508 } 1509 1510 } 1511 1512 class Putv_charFn extends BuiltinFunction 1513 { opn(LispObject [] args)1514 public LispObject opn(LispObject [] args) throws Exception 1515 { 1516 if (args.length != 3) 1517 return error("putv-char called with " + args.length + 1518 "args when 3 expected"); 1519 String v = ((LispString)args[0]).string; 1520 LispSmallInteger n = (LispSmallInteger)args[1]; 1521 int i = n.value; 1522 char [] v1 = v.toCharArray(); 1523 v1[i] = (char)(((LispSmallInteger)args[2]).value); 1524 ((LispString)args[0]).string = new String(v1); 1525 return args[2]; 1526 } 1527 } 1528 1529 class Putv16Fn extends BuiltinFunction 1530 { op1(LispObject arg1)1531 public LispObject op1(LispObject arg1) throws Exception 1532 { 1533 return error(name + " not yet implemented"); 1534 } 1535 } 1536 1537 class Putv32Fn extends BuiltinFunction 1538 { op1(LispObject arg1)1539 public LispObject op1(LispObject arg1) throws Exception 1540 { 1541 return error(name + " not yet implemented"); 1542 } 1543 } 1544 1545 class Putv8Fn extends BuiltinFunction 1546 { op1(LispObject arg1)1547 public LispObject op1(LispObject arg1) throws Exception 1548 { 1549 return error(name + " not yet implemented"); 1550 } 1551 } 1552 1553 class QcaarFn extends BuiltinFunction 1554 { op1(LispObject arg1)1555 public LispObject op1(LispObject arg1) 1556 { 1557 return arg1.car.car; 1558 } 1559 } 1560 1561 class QcadrFn extends BuiltinFunction 1562 { op1(LispObject arg1)1563 public LispObject op1(LispObject arg1) throws Exception 1564 { 1565 return arg1.cdr.car; 1566 } 1567 } 1568 1569 class QcarFn extends BuiltinFunction 1570 { op1(LispObject arg1)1571 public LispObject op1(LispObject arg1) throws Exception 1572 { 1573 return arg1.car; 1574 } 1575 } 1576 1577 class QcdarFn extends BuiltinFunction 1578 { op1(LispObject arg1)1579 public LispObject op1(LispObject arg1) throws Exception 1580 { 1581 return arg1.car.cdr; 1582 } 1583 } 1584 1585 class QcddrFn extends BuiltinFunction 1586 { op1(LispObject arg1)1587 public LispObject op1(LispObject arg1) throws Exception 1588 { 1589 return arg1.cdr.cdr; 1590 } 1591 } 1592 1593 class QcdrFn extends BuiltinFunction 1594 { op1(LispObject arg1)1595 public LispObject op1(LispObject arg1) throws Exception 1596 { 1597 return arg1.cdr; 1598 } 1599 } 1600 1601 class QgetvFn extends BuiltinFunction 1602 { op2(LispObject arg1, LispObject arg2)1603 public LispObject op2(LispObject arg1, LispObject arg2) 1604 { 1605 LispVector v = (LispVector)arg1; 1606 return v.vec[((LispSmallInteger)arg2).value]; 1607 } 1608 } 1609 1610 class QputvFn extends BuiltinFunction 1611 { op1(LispObject arg1)1612 public LispObject op1(LispObject arg1) throws Exception 1613 { 1614 return error(name + " not yet implemented"); 1615 } 1616 } 1617 1618 class RassocFn extends BuiltinFunction 1619 { op1(LispObject arg1)1620 public LispObject op1(LispObject arg1) throws Exception 1621 { 1622 return error(name + " not yet implemented"); 1623 } 1624 } 1625 1626 class RdfFn extends BuiltinFunction 1627 { op1(LispObject arg1)1628 public LispObject op1(LispObject arg1) throws Exception 1629 { 1630 if (!(arg1 instanceof LispString)) 1631 return error("argument for rdf should be a string"); 1632 String name = ((LispString)arg1).string; 1633 LispObject save = Jlisp.lit[Lit.std_input].car/*value*/; 1634 try 1635 { Jlisp.lit[Lit.std_input].car/*value*/ = 1636 new LispStream( 1637 name, 1638 new BufferedReader( 1639 new FileReader(LispStream.nameConvert(name))), 1640 false, true); 1641 try 1642 { Jlisp.println(); 1643 // here I really want the simple READ-EVAL-PRINT 1644 // without any messing with any restart function. 1645 Jlisp.restarting = false; // just to be ultra-careful! 1646 Jlisp.readEvalPrintLoop(true); 1647 } 1648 finally 1649 { ((LispStream)Jlisp.lit[Lit.std_input].car/*value*/).close(); 1650 } 1651 } 1652 catch (FileNotFoundException e) 1653 { return error("Unable to read from \"" + 1654 name + "\""); 1655 } 1656 finally 1657 { Jlisp.lit[Lit.std_input].car/*value*/ = save; 1658 Jlisp.println("+++ end of reading " + name); 1659 } 1660 return Jlisp.nil; 1661 } 1662 } 1663 1664 class RdsFn extends BuiltinFunction 1665 { op1(LispObject arg1)1666 public LispObject op1(LispObject arg1) 1667 { 1668 // The issue of what to select if the user says (rds nil) is a bit horrid 1669 // here in terms of how it should react with the user also re-setting 1670 // or re-binding !*std-input!* and the other related variables. Here I 1671 // do something that probably works well enough for REDUCE... 1672 if (arg1 == Jlisp.nil) arg1 = Jlisp.lit[Lit.terminal_io].car/*value*/; 1673 LispObject prev = Jlisp.lit[Lit.std_input].car/*value*/; 1674 Jlisp.lit[Lit.std_input].car/*value*/ = (LispStream)arg1; 1675 return prev; 1676 } 1677 } 1678 1679 class ReadFn extends BuiltinFunction 1680 { op0()1681 public LispObject op0() throws Exception 1682 { 1683 LispObject w = Jlisp.lit[Lit.eof]; 1684 try 1685 { w = Jlisp.read(); 1686 } 1687 catch (EOFException e) 1688 { return Jlisp.lit[Lit.eof]; 1689 } 1690 catch (IOException e) 1691 { Jlisp.errprintln("Reader error: " + e.getMessage()); 1692 } 1693 return w; 1694 } 1695 } 1696 1697 class ReadchFn extends BuiltinFunction 1698 { op0()1699 public LispObject op0() throws Exception 1700 { 1701 try 1702 { int ch; 1703 do 1704 { ch = ((LispStream)Jlisp.lit[Lit.std_input].car/*value*/ 1705 ).readChar(); 1706 } while (ch == '\r'); // wary of Windows (& DOS) 1707 if (ch < 0) return Jlisp.lit[Lit.eof]; 1708 else if (ch < 128) return Jlisp.chars[ch]; 1709 else return Symbol.intern(String.valueOf((char)ch)); 1710 } 1711 catch (IOException e) 1712 { return error("IO error detected in readch"); 1713 } 1714 } 1715 } 1716 1717 class ReadlineFn extends BuiltinFunction 1718 { op0()1719 public LispObject op0() throws Exception 1720 { 1721 StringBuffer s = new StringBuffer(); 1722 LispObject sr = Jlisp.lit[Lit.raise].car/*value*/; 1723 LispObject sl = Jlisp.lit[Lit.lower].car/*value*/; 1724 Jlisp.lit[Lit.raise].car/*value*/ = Jlisp.nil; 1725 Jlisp.lit[Lit.lower].car/*value*/ = Jlisp.nil; 1726 try 1727 { int c; 1728 boolean any = false; 1729 LispStream r = (LispStream)Jlisp.lit[Lit.std_input].car/*value*/; 1730 while ((c = r.readChar()) != '\n' && 1731 c != -1) 1732 { if (c != '\r') 1733 { s.append((char)c); 1734 any = true; 1735 } 1736 } 1737 if (c == -1 && !any) return Jlisp.lit[Lit.eof]; 1738 else return new LispString(new String(s)); 1739 } 1740 catch (IOException e) 1741 { return error("IO error detected in readline"); 1742 } 1743 finally 1744 { Jlisp.lit[Lit.raise].car/*value*/ = sr; 1745 Jlisp.lit[Lit.lower].car/*value*/ = sl; 1746 } 1747 } op1(LispObject a1)1748 public LispObject op1(LispObject a1) throws Exception 1749 { 1750 StringBuffer s = new StringBuffer(); 1751 LispObject sr = Jlisp.lit[Lit.raise].car/*value*/; 1752 LispObject sl = Jlisp.lit[Lit.lower].car/*value*/; 1753 Jlisp.lit[Lit.raise].car/*value*/ = Jlisp.nil; 1754 Jlisp.lit[Lit.lower].car/*value*/ = Jlisp.nil; 1755 try 1756 { int c; 1757 boolean any = false; 1758 LispStream r = (LispStream)a1; 1759 while ((c = r.readChar()) != '\n' && 1760 c != -1) 1761 { if (c != '\r') 1762 { s.append((char)c); 1763 any = true; 1764 } 1765 } 1766 if (c == -1 && !any) return Jlisp.lit[Lit.eof]; 1767 else return new LispString(new String(s)); 1768 } 1769 catch (IOException e) 1770 { return error("IO error detected in readline"); 1771 } 1772 finally 1773 { Jlisp.lit[Lit.raise].car/*value*/ = sr; 1774 Jlisp.lit[Lit.lower].car/*value*/ = sl; 1775 } 1776 } 1777 } 1778 1779 class ReclaimFn extends BuiltinFunction 1780 { op1(LispObject arg1)1781 public LispObject op1(LispObject arg1) throws Exception 1782 { 1783 return error(name + " not yet implemented"); 1784 } 1785 } 1786 1787 class RemdFn extends BuiltinFunction 1788 { op1(LispObject arg1)1789 public LispObject op1(LispObject arg1) throws Exception 1790 { 1791 Symbol a = (Symbol)arg1; 1792 a.completeName(); 1793 a.fn = new Undefined(a.pname); 1794 return a; 1795 } 1796 } 1797 1798 class RemflagFn extends BuiltinFunction 1799 { op2(LispObject arg1, LispObject arg2)1800 public LispObject op2(LispObject arg1, LispObject arg2) 1801 { 1802 while (!arg1.atom) 1803 { LispObject p = arg1; 1804 Symbol s = (Symbol)p.car; 1805 arg1 = p.cdr; 1806 Fns.remprop(s, arg2); 1807 } 1808 return Jlisp.nil; 1809 } 1810 } 1811 1812 class RemhashFn extends BuiltinFunction 1813 { op1(LispObject key)1814 public LispObject op1(LispObject key) 1815 { 1816 LispObject r = (LispObject) 1817 ((LispHash)Jlisp.lit[Lit.hashtab]).hash.remove(key); 1818 if (r == null) r = Jlisp.nil; 1819 return r; 1820 } op2(LispObject key, LispObject table)1821 public LispObject op2(LispObject key, LispObject table) 1822 { 1823 LispHash h = (LispHash)table; 1824 LispObject r = (LispObject)h.hash.remove(key); 1825 if (r == null) r = Jlisp.nil; 1826 return r; 1827 } opn(LispObject [] args)1828 public LispObject opn(LispObject [] args) throws Exception 1829 { 1830 if (args.length != 3) 1831 return error("remhash called with " + args.length + 1832 "args when 1 to 3 expected"); 1833 LispObject key = args[0]; 1834 LispHash h = (LispHash)args[1]; 1835 LispObject defaultValue = args[2]; 1836 LispObject r = (LispObject)h.hash.remove(key); 1837 if (r == null) r = defaultValue; 1838 return r; 1839 } 1840 } 1841 1842 class RemobFn extends BuiltinFunction 1843 { op1(LispObject arg1)1844 public LispObject op1(LispObject arg1) throws Exception 1845 { 1846 if (arg1 instanceof Symbol) Symbol.remob((Symbol)arg1); 1847 return arg1; 1848 } 1849 } 1850 1851 class RempropFn extends BuiltinFunction 1852 { op2(LispObject arg1, LispObject arg2)1853 public LispObject op2(LispObject arg1, LispObject arg2) throws Exception 1854 { 1855 if (!(arg1 instanceof Symbol)) return Jlisp.nil; 1856 else return Fns.remprop((Symbol)arg1, arg2); 1857 } 1858 } 1859 1860 class Rename_fileFn extends BuiltinFunction 1861 { op2(LispObject arg1, LispObject arg2)1862 public LispObject op2(LispObject arg1, LispObject arg2) throws Exception 1863 { 1864 String s; 1865 if (arg1 instanceof Symbol) 1866 { ((Symbol)arg1).completeName(); 1867 s = ((Symbol)arg1).pname; 1868 } 1869 else if (arg1 instanceof LispString) s = ((LispString)arg1).string; 1870 else return Jlisp.nil; 1871 String s1; 1872 if (arg2 instanceof Symbol) 1873 { ((Symbol)arg1).completeName(); 1874 s1 = ((Symbol)arg2).pname; 1875 } 1876 else if (arg2 instanceof LispString) s1 = ((LispString)arg2).string; 1877 else return Jlisp.nil; 1878 return LispStream.fileRename(s, s1); 1879 } 1880 } 1881 1882 class RepresentationFn extends BuiltinFunction 1883 { op1(LispObject arg1)1884 public LispObject op1(LispObject arg1) throws Exception 1885 { 1886 return error(name + " not yet implemented"); 1887 } 1888 } 1889 1890 class ReturnFn extends BuiltinFunction 1891 { op1(LispObject arg1)1892 public LispObject op1(LispObject arg1) throws ProgEvent 1893 { 1894 Specfn.progEvent = Specfn.RETURN; 1895 Specfn.progData = arg1; 1896 return arg1; 1897 } 1898 } 1899 1900 class ReverseFn extends BuiltinFunction 1901 { op1(LispObject arg1)1902 public LispObject op1(LispObject arg1) throws ResourceException 1903 { 1904 LispObject r = Jlisp.nil; 1905 while (!arg1.atom) 1906 { LispObject a = arg1; 1907 r = new Cons(a.car, r); 1908 arg1 = a.cdr; 1909 } 1910 return r; 1911 } 1912 } 1913 1914 class ReversipFn extends BuiltinFunction 1915 { op1(LispObject arg1)1916 public LispObject op1(LispObject arg1) 1917 { 1918 LispObject r = Jlisp.nil; 1919 while (!arg1.atom) 1920 { LispObject a = arg1; 1921 arg1 = a.cdr; 1922 a.cdr = r; 1923 r = a; 1924 } 1925 return r; 1926 } op2(LispObject arg1, LispObject arg2)1927 public LispObject op2(LispObject arg1, LispObject arg2) 1928 { 1929 LispObject r = arg2; 1930 while (!arg1.atom) 1931 { LispObject a = arg1; 1932 arg1 = a.cdr; 1933 a.cdr = r; 1934 r = a; 1935 } 1936 return r; 1937 } 1938 } 1939 1940 class RplacaFn extends BuiltinFunction 1941 { op2(LispObject arg1, LispObject arg2)1942 public LispObject op2(LispObject arg1, LispObject arg2) throws Exception 1943 { 1944 if (arg1.atom) return error("bad arg to rplaca"); 1945 arg1.car = arg2; 1946 return arg1; 1947 } 1948 } 1949 1950 class RplacdFn extends BuiltinFunction 1951 { op2(LispObject arg1, LispObject arg2)1952 public LispObject op2(LispObject arg1, LispObject arg2) throws Exception 1953 { 1954 if (arg1.atom) return error("bad arg to rplacd"); 1955 arg1.cdr = arg2; 1956 return arg1; 1957 } 1958 } 1959 1960 class RplacwFn extends BuiltinFunction 1961 { op2(LispObject arg1, LispObject arg2)1962 public LispObject op2(LispObject arg1, LispObject arg2) throws Exception 1963 { 1964 if (arg1.atom || arg2.atom) return error("bad arg to rplacw"); 1965 arg1.car = arg2.car; 1966 arg1.cdr = arg2.cdr; 1967 return arg1; 1968 } 1969 } 1970 1971 class RseekFn extends BuiltinFunction 1972 { op1(LispObject arg1)1973 public LispObject op1(LispObject arg1) throws Exception 1974 { 1975 return error(name + " not yet implemented"); 1976 } 1977 } 1978 1979 class RtellFn extends BuiltinFunction 1980 { op1(LispObject arg1)1981 public LispObject op1(LispObject arg1) throws Exception 1982 { 1983 return error(name + " not yet implemented"); 1984 } 1985 } 1986 1987 class SampleFn extends BuiltinFunction 1988 { op1(LispObject arg1)1989 public LispObject op1(LispObject arg1) throws Exception 1990 { 1991 return error(name + " not yet implemented"); 1992 } 1993 } 1994 1995 class SassocFn extends BuiltinFunction 1996 { op1(LispObject arg1)1997 public LispObject op1(LispObject arg1) throws Exception 1998 { 1999 return error(name + " not yet implemented"); 2000 } 2001 } 2002 2003 class ScharFn extends BuiltinFunction 2004 { op2(LispObject arg1, LispObject arg2)2005 public LispObject op2(LispObject arg1, LispObject arg2) 2006 { 2007 int n = ((LispSmallInteger)arg2).value; 2008 String s = ((LispString)arg1).string; 2009 char ch = s.charAt(n); 2010 if (ch < 128) return Jlisp.chars[ch]; 2011 else return Symbol.intern(String.valueOf((char)ch)); 2012 } 2013 } 2014 2015 class SeprpFn extends BuiltinFunction 2016 { op1(LispObject arg1)2017 public LispObject op1(LispObject arg1) throws Exception 2018 { 2019 // blank end-of-line tab form-fee carriage-return 2020 if (arg1 == Jlisp.lit[Lit.space] || 2021 arg1 == Jlisp.lit[Lit.newline] || 2022 arg1 == Jlisp.lit[Lit.tab] || 2023 arg1 == Jlisp.lit[Lit.formFeed] || 2024 arg1 == Jlisp.lit[Lit.cr]) 2025 return Jlisp.lispTrue; 2026 else return Jlisp.nil; 2027 } 2028 } 2029 2030 class SetFn extends BuiltinFunction 2031 { op2(LispObject arg1, LispObject arg2)2032 public LispObject op2(LispObject arg1, LispObject arg2) 2033 { 2034 ((Symbol)arg1).car/*value*/ = arg2; 2035 return arg2; 2036 } 2037 } 2038 2039 class Set_autoloadFn extends BuiltinFunction 2040 { op2(LispObject name, LispObject data)2041 public LispObject op2(LispObject name, LispObject data) throws Exception 2042 { 2043 Symbol f = (Symbol)name; 2044 if (data.atom) 2045 data = new Cons(data, Jlisp.nil); 2046 f.fn = new AutoLoad(f, data); 2047 return name; 2048 } 2049 } 2050 2051 class Set_help_fileFn extends BuiltinFunction 2052 { op1(LispObject arg1)2053 public LispObject op1(LispObject arg1) throws Exception 2054 { 2055 return error(name + " not yet implemented"); 2056 } 2057 } 2058 2059 class Set_print_precisionFn extends BuiltinFunction 2060 { op1(LispObject arg1)2061 public LispObject op1(LispObject arg1) throws Exception 2062 { 2063 int n = Jlisp.printprec; 2064 Jlisp.printprec = ((LispSmallInteger)arg1).value; 2065 return LispInteger.valueOf(n); 2066 } 2067 } 2068 2069 class Get_print_precisionFn extends BuiltinFunction 2070 { op0()2071 public LispObject op0() throws Exception 2072 { 2073 return LispInteger.valueOf(Jlisp.printprec); 2074 } 2075 } 2076 2077 class SetpcharFn extends BuiltinFunction 2078 { op1(LispObject arg1)2079 public LispObject op1(LispObject arg1) throws Exception 2080 { 2081 String old = Fns.prompt; 2082 if (old == null) old = ""; // just in case! 2083 if (arg1 instanceof LispString) 2084 Fns.prompt = ((LispString)arg1).string; 2085 else if (arg1 instanceof Symbol) 2086 { ((Symbol)arg1).completeName(); 2087 Fns.prompt = ((Symbol)arg1).pname; 2088 } 2089 else Fns.prompt = null; // use system default 2090 return new LispString(old); 2091 } 2092 } 2093 2094 class Simple_string_pFn extends BuiltinFunction 2095 { op1(LispObject arg1)2096 public LispObject op1(LispObject arg1) 2097 { 2098 if (arg1 instanceof LispString) return Jlisp.lispTrue; 2099 else return Jlisp.nil; 2100 } 2101 } 2102 2103 class Simple_vector_pFn extends BuiltinFunction 2104 { op1(LispObject arg1)2105 public LispObject op1(LispObject arg1) 2106 { 2107 if (arg1 instanceof LispVector) return Jlisp.lispTrue; 2108 else return Jlisp.nil; 2109 } 2110 } 2111 2112 class SmemqFn extends BuiltinFunction 2113 { 2114 op2(LispObject arg1, LispObject arg2)2115 public LispObject op2(LispObject arg1, LispObject arg2) throws Exception 2116 { 2117 while (!arg2.atom) 2118 { LispObject a = arg2; 2119 if (a.car == Jlisp.lit[Lit.quote]) return Jlisp.nil; 2120 else if (op2(arg1, a.car) != Jlisp.nil) 2121 return Jlisp.lispTrue; 2122 else arg2 = a.cdr; 2123 } 2124 if (arg1 == arg2) return Jlisp.lispTrue; 2125 else return Jlisp.nil; 2126 } 2127 } 2128 2129 class SpacesFn extends BuiltinFunction 2130 { op1(LispObject arg1)2131 public LispObject op1(LispObject arg1) throws ResourceException 2132 { 2133 int n = ((LispSmallInteger)arg1).value; 2134 for (int i=0; i<n; i++) 2135 Jlisp.print(" "); 2136 return Jlisp.nil; 2137 } 2138 } 2139 2140 class Special_charFn extends BuiltinFunction 2141 { 2142 op1(LispObject arg1)2143 public LispObject op1(LispObject arg1) throws Exception 2144 { 2145 LispSmallInteger a = (LispSmallInteger)arg1; 2146 int n = a.value; 2147 LispObject [] t = Jlisp.lit; 2148 switch (n) 2149 { 2150 case 0: return t[Lit.space]; 2151 case 1: return t[Lit.newline]; 2152 case 2: return t[Lit.backspace]; 2153 case 3: return t[Lit.tab]; 2154 // case 4: vertical tab 2155 case 5: return t[Lit.formFeed]; 2156 case 6: return t[Lit.cr]; 2157 case 7: return t[Lit.rubout]; 2158 case 8: return t[Lit.eof]; 2159 // case 9: ctrl-G 2160 case 10: return t[Lit.escape]; 2161 default: return Jlisp.nil; 2162 } 2163 } 2164 } 2165 2166 class Special_form_pFn extends BuiltinFunction 2167 { op1(LispObject arg1)2168 public LispObject op1(LispObject arg1) throws Exception 2169 { return (arg1 instanceof Symbol && 2170 ((Symbol)arg1).special != null) ? 2171 Jlisp.lispTrue : 2172 Jlisp.nil; 2173 } 2174 } 2175 2176 class SpoolFn extends BuiltinFunction 2177 { op1(LispObject arg1)2178 public LispObject op1(LispObject arg1) throws Exception 2179 { 2180 return error(name + " not yet implemented"); 2181 } 2182 } 2183 2184 class Start_moduleFn extends BuiltinFunction 2185 { op1(LispObject arg1)2186 public LispObject op1(LispObject arg1) throws Exception 2187 { 2188 return Fasl.startModule(arg1); 2189 } 2190 } 2191 2192 // (stop) exist from this Lisp. 2193 2194 class StopFn extends BuiltinFunction 2195 { op1(LispObject arg1)2196 public LispObject op1(LispObject arg1) throws Exception 2197 { 2198 Jlisp.println(); 2199 Jlisp.backtrace = false; 2200 throw new ProgEvent(ProgEvent.STOP, arg1, "STOP function called"); 2201 } 2202 } 2203 2204 class StreampFn extends BuiltinFunction 2205 { op1(LispObject arg1)2206 public LispObject op1(LispObject arg1) 2207 { 2208 return arg1 instanceof LispStream ? 2209 Jlisp.lispTrue : 2210 Jlisp.nil; 2211 } 2212 } 2213 2214 class StringpFn extends BuiltinFunction 2215 { op1(LispObject arg1)2216 public LispObject op1(LispObject arg1) 2217 { 2218 return arg1 instanceof LispString ? Jlisp.lispTrue : 2219 Jlisp.nil; 2220 } 2221 } 2222 2223 class Stub1Fn extends BuiltinFunction 2224 { op1(LispObject arg1)2225 public LispObject op1(LispObject arg1) 2226 { 2227 return Jlisp.nil; 2228 } 2229 } 2230 2231 class Stub2Fn extends BuiltinFunction 2232 { op2(LispObject arg1, LispObject arg2)2233 public LispObject op2(LispObject arg1, LispObject arg2) 2234 { 2235 return Jlisp.nil; 2236 } 2237 } 2238 2239 class SublaFn extends BuiltinFunction 2240 { op2(LispObject u, LispObject v)2241 public LispObject op2(LispObject u, LispObject v) throws Exception 2242 { 2243 if (u == Jlisp.nil || 2244 v == Jlisp.nil) return v; 2245 else if (v.atom) 2246 { while (!u.atom) 2247 { LispObject cu = u; 2248 u = cu.cdr; 2249 if (cu.car.atom) continue; 2250 LispObject ccu = cu.car; 2251 if (v instanceof LispNumber) // @@@ 2252 { if (v.lispequals(ccu.car)) return ccu.car; // @@@ 2253 } // @@@ 2254 else if (ccu.car == v) return ccu.cdr; 2255 } 2256 return v; 2257 } 2258 LispObject cv = v; 2259 LispObject y = new Cons( 2260 op2(u, cv.car), 2261 op2(u, cv.cdr)); 2262 if (y.lispequals(v)) return v; 2263 else return y; 2264 } 2265 } 2266 2267 class SublisFn extends BuiltinFunction 2268 { op2(LispObject al, LispObject x)2269 public LispObject op2(LispObject al, LispObject x) throws Exception 2270 { 2271 LispObject a = al; 2272 while (!a.atom) 2273 { LispObject c = a; 2274 a = c.cdr; 2275 if (c.car.atom) continue; 2276 LispObject cc = c.car; 2277 if (cc.car.lispequals(x)) return cc.cdr; 2278 } 2279 if (x.atom) return x; 2280 LispObject cx = x; 2281 LispObject aa = op2(al, cx.car); 2282 LispObject bb = op2(al, cx.cdr); 2283 if (aa == cx.car && bb == cx.cdr) return x; 2284 else return new Cons(aa, bb); 2285 } 2286 } 2287 2288 class SubstFn extends BuiltinFunction 2289 { opn(LispObject [] args)2290 public LispObject opn(LispObject [] args) throws Exception 2291 { 2292 if (args.length != 3) 2293 return error("subst called with " + args.length + 2294 "args when 1 to 3 expected"); 2295 return subst(args[0], args[1], args[2]); 2296 } 2297 subst(LispObject a, LispObject b, LispObject c)2298 LispObject subst(LispObject a, LispObject b, LispObject c) throws ResourceException 2299 { 2300 if (b.lispequals(c)) return a; 2301 if (c.atom) return c; 2302 LispObject cc = c; 2303 LispObject aa = subst(a, b, cc.car); 2304 LispObject bb = subst(a, b, cc.cdr); 2305 if (aa == cc.car && bb == cc.cdr) return c; 2306 else return new Cons(aa, bb); 2307 } 2308 } 2309 2310 class SubstqFn extends BuiltinFunction 2311 { opn(LispObject [] args)2312 public LispObject opn(LispObject [] args) throws Exception 2313 { 2314 if (args.length != 3) 2315 return error("substq called with " + args.length + 2316 "args when 1 to 3 expected"); 2317 return substq(args[0], args[1], args[2]); 2318 } 2319 substq(LispObject a, LispObject b, LispObject c)2320 LispObject substq(LispObject a, LispObject b, LispObject c) throws ResourceException 2321 { 2322 if (b instanceof LispNumber) 2323 { if (b.lispequals(c)) return a; 2324 } 2325 else if (b == c) return a; 2326 if (c.atom) return c; 2327 LispObject cc = c; 2328 LispObject aa = substq(a, b, cc.car); 2329 LispObject bb = substq(a, b, cc.cdr); 2330 if (aa == cc.car && bb == cc.cdr) return c; 2331 else return new Cons(aa, bb); 2332 } 2333 } 2334 2335 class SxhashFn extends BuiltinFunction 2336 { // use md60 here... op1(LispObject arg1)2337 public LispObject op1(LispObject arg1) throws Exception 2338 { 2339 LispStream f = new LispDigester(); 2340 LispObject save = Jlisp.lit[Lit.std_output].car/*value*/; 2341 try 2342 { Jlisp.lit[Lit.std_output].car/*value*/ = f; 2343 arg1.print(LispObject.noLineBreak+LispObject.printEscape); 2344 } 2345 finally 2346 { Jlisp.lit[Lit.std_output].car/*value*/ = save; 2347 } 2348 byte [] res = f.md.digest(); 2349 return LispInteger.valueOf(new BigInteger(res).shiftRight(68)); 2350 } 2351 } 2352 2353 class Symbol_argcountFn extends BuiltinFunction 2354 { op1(LispObject arg1)2355 public LispObject op1(LispObject arg1) throws Exception 2356 { 2357 return error(name + " not yet implemented"); 2358 } 2359 } 2360 2361 class Symbol_envFn extends BuiltinFunction 2362 { op1(LispObject arg1)2363 public LispObject op1(LispObject arg1) 2364 { 2365 if (!(arg1 instanceof Symbol)) return Jlisp.nil; 2366 LispFunction f = ((Symbol)arg1).fn; 2367 if (f instanceof FnWithEnv) 2368 return new LispVector(((FnWithEnv)f).env); 2369 else return Jlisp.nil; 2370 } 2371 } 2372 2373 class Symbol_fastgetsFn extends BuiltinFunction 2374 { op1(LispObject arg1)2375 public LispObject op1(LispObject arg1) throws Exception 2376 { 2377 return error(name + " not yet implemented"); 2378 } 2379 } 2380 2381 class Symbol_fn_cellFn extends BuiltinFunction 2382 { op1(LispObject arg1)2383 public LispObject op1(LispObject arg1) throws Exception 2384 { 2385 LispFunction f = ((Symbol)arg1).fn; 2386 if (f instanceof Undefined) return Jlisp.nil; 2387 else return f; 2388 } 2389 } 2390 2391 class Symbol_functionFn extends BuiltinFunction 2392 { op1(LispObject arg1)2393 public LispObject op1(LispObject arg1) throws Exception 2394 { 2395 return ((Symbol)arg1).fn; 2396 } 2397 } 2398 2399 class Symbol_make_fastgetFn extends BuiltinFunction 2400 { op1(LispObject arg1)2401 public LispObject op1(LispObject arg1) 2402 { 2403 return Jlisp.nil; 2404 } op2(LispObject arg1, LispObject arg2)2405 public LispObject op2(LispObject arg1, LispObject arg2) 2406 { 2407 return Jlisp.nil; 2408 } 2409 } 2410 2411 class Symbol_nameFn extends BuiltinFunction 2412 { op1(LispObject arg1)2413 public LispObject op1(LispObject arg1) throws Exception 2414 { 2415 ((Symbol)arg1).completeName(); 2416 return new LispString(((Symbol)arg1).pname); 2417 } 2418 } 2419 2420 class Symbol_protectFn extends BuiltinFunction 2421 { op1(LispObject arg1)2422 public LispObject op1(LispObject arg1) throws Exception 2423 { 2424 return error(name + " not yet implemented"); 2425 } 2426 } 2427 2428 class Symbol_set_definitionFn extends BuiltinFunction 2429 { op2(LispObject arg1, LispObject arg2)2430 public LispObject op2(LispObject arg1, LispObject arg2) throws Exception 2431 { 2432 Symbol a1 = (Symbol)arg1; 2433 if (!arg2.atom) 2434 { LispObject a2 = arg2; 2435 if (a2.car == Jlisp.lit[Lit.lambda]) 2436 { a1.fn = new Interpreted(a2.cdr); 2437 return arg1; 2438 } 2439 else if (a2.car instanceof LispInteger) 2440 { int nargs = a2.car.intValue(); 2441 int nopts = nargs >> 8; 2442 int flagbits = nopts >> 8; 2443 int ntail = flagbits >> 2; 2444 nargs &= 0xff; 2445 nopts &= 0xff; 2446 flagbits &= 0x03; 2447 // The next few cases are where a function is defined as a direct call 2448 // to another, possibly discarding a few final args. Eg 2449 // (de f (a b) (g a)) 2450 if (ntail != 0) 2451 { a1.fn = new CallAs(nargs, a2.cdr.cdr, ntail-1); 2452 return arg1; 2453 } 2454 a2 = a2.cdr; 2455 if (a2.atom) return Jlisp.nil; 2456 Bytecode b = (Bytecode)a2.car; 2457 LispVector v = (LispVector)a2.cdr; 2458 if (flagbits != 0 || nopts != 0) 2459 { 2460 // What is happening here is a MESS inherited from CSL. 2461 // nopts = number of optional args wanted 2462 // flagbits & 1 "hard case": pass Spid.noarg not nil for missing opts 2463 // flagbits & 2 &rest arg present 2464 b = new ByteOpt(b.bytecodes, v.vec, 2465 nargs, nopts, flagbits); 2466 } 2467 else 2468 { b.env = v.vec; 2469 b.nargs = nargs; 2470 } 2471 a1.fn = b; 2472 return arg1; 2473 } 2474 // Otherwise drop through and moan 2475 } 2476 else if (arg2 instanceof Symbol) 2477 { Symbol a2 = (Symbol)arg2; 2478 a1.fn = a2.fn; 2479 return arg1; 2480 } 2481 else if (arg2 instanceof LispFunction) 2482 { a1.fn = (LispFunction)arg2; 2483 return arg1; 2484 } 2485 // Unrecognised cases follow - just print a message 2486 Jlisp.println(); 2487 arg1.print(LispObject.printEscape); 2488 Jlisp.print(" => "); 2489 arg2.print(); 2490 Jlisp.println(); 2491 return Jlisp.nil; 2492 } 2493 } 2494 2495 class Symbol_set_envFn extends BuiltinFunction 2496 { op2(LispObject arg1, LispObject arg2)2497 public LispObject op2(LispObject arg1, LispObject arg2) throws Exception 2498 { 2499 if (!(arg1 instanceof Symbol)) return Jlisp.nil; 2500 LispFunction f = ((Symbol)arg1).fn; 2501 if (f instanceof FnWithEnv) 2502 ((FnWithEnv)f).env = ((LispVector)arg2).vec; 2503 else return Jlisp.nil; // quiet in case it fails? 2504 return arg2; 2505 } 2506 } 2507 2508 class Symbol_set_nativeFn extends BuiltinFunction 2509 { op1(LispObject arg1)2510 public LispObject op1(LispObject arg1) throws Exception 2511 { 2512 return error(name + " not yet implemented"); 2513 } 2514 } 2515 2516 class Symbol_valueFn extends BuiltinFunction 2517 { op1(LispObject arg1)2518 public LispObject op1(LispObject arg1) 2519 { 2520 return ((Symbol)arg1).car/*value*/; 2521 } 2522 } 2523 2524 class SymbolpFn extends BuiltinFunction 2525 { op1(LispObject arg1)2526 public LispObject op1(LispObject arg1) throws Exception 2527 { return arg1 instanceof Symbol ? Jlisp.lispTrue : 2528 Jlisp.nil; 2529 } 2530 } 2531 2532 class SymerrFn extends BuiltinFunction 2533 { op1(LispObject arg1)2534 public LispObject op1(LispObject arg1) throws Exception 2535 { 2536 return error(name + " not yet implemented"); 2537 } 2538 } 2539 2540 class SystemFn extends BuiltinFunction 2541 { op1(LispObject arg1)2542 public LispObject op1(LispObject arg1) throws Exception 2543 { 2544 try 2545 { Runtime r = Runtime.getRuntime(); 2546 r.exec(((LispString)arg1).string); 2547 } 2548 catch (IOException e) 2549 { return Jlisp.nil; 2550 } 2551 catch (SecurityException e) 2552 { return Jlisp.nil; 2553 } 2554 return Jlisp.lispTrue; 2555 } 2556 } 2557 2558 class TagbodyFn extends BuiltinFunction 2559 { op1(LispObject arg1)2560 public LispObject op1(LispObject arg1) throws Exception 2561 { 2562 return error(name + " not yet implemented"); 2563 } 2564 } 2565 2566 class TerpriFn extends BuiltinFunction 2567 { op0()2568 public LispObject op0() throws ResourceException 2569 { 2570 Jlisp.println(); 2571 return Jlisp.nil; 2572 } 2573 } 2574 2575 class ThreevectorpFn extends BuiltinFunction 2576 { op1(LispObject arg1)2577 public LispObject op1(LispObject arg1) throws Exception 2578 { 2579 if (arg1 instanceof LispVector && 2580 ((LispVector)arg1).vec.length == 3) return Jlisp.lispTrue; 2581 else return Jlisp.nil; 2582 } 2583 } 2584 2585 class ThrowFn extends BuiltinFunction 2586 { op1(LispObject arg1)2587 public LispObject op1(LispObject arg1) throws Exception 2588 { 2589 return error(name + " not yet implemented"); 2590 } 2591 } 2592 2593 class TimeFn extends BuiltinFunction 2594 { op0()2595 public LispObject op0() throws Exception 2596 { 2597 return LispInteger.valueOf(System.currentTimeMillis()); 2598 } 2599 } 2600 2601 class TmpnamFn extends BuiltinFunction 2602 { op0()2603 public LispObject op0() throws Exception 2604 { 2605 // Not really satisfactory - but I hope that nobody uses this! 2606 return new LispString("tempfile.tmp"); 2607 } op1(LispObject arg1)2608 public LispObject op1(LispObject arg1) throws Exception 2609 { String s; 2610 if (arg1 instanceof Symbol) 2611 { ((Symbol)arg1).completeName(); 2612 s = ((Symbol)arg1).pname; 2613 } 2614 else if (arg1 instanceof LispString) s = ((LispString)arg1).string; 2615 else s = "tmp"; 2616 return new LispString("tempfile." + s); 2617 } 2618 } 2619 2620 class TraceFn extends BuiltinFunction 2621 { op1(LispObject arg1)2622 public LispObject op1(LispObject arg1) throws Exception 2623 { 2624 while (!arg1.atom) 2625 { Symbol n = (Symbol)arg1.car; 2626 if (!(n.fn instanceof TracedFunction)) 2627 n.fn = new TracedFunction(n, n.fn); 2628 arg1 = arg1.cdr; 2629 } 2630 return Jlisp.nil; 2631 } 2632 } 2633 2634 class TracesetFn extends BuiltinFunction 2635 { op1(LispObject arg1)2636 public LispObject op1(LispObject arg1) throws Exception 2637 { 2638 return error(name + " not yet implemented"); 2639 } 2640 } 2641 2642 class Traceset1Fn extends BuiltinFunction 2643 { op1(LispObject arg1)2644 public LispObject op1(LispObject arg1) throws Exception 2645 { 2646 return error(name + " not yet implemented"); 2647 } 2648 } 2649 2650 class TtabFn extends BuiltinFunction 2651 { op1(LispObject arg1)2652 public LispObject op1(LispObject arg1) throws ResourceException 2653 { 2654 int n = ((LispSmallInteger)arg1).value; 2655 LispStream f = (LispStream)Jlisp.lit[Lit.std_output].car/*value*/; 2656 while (f.column < n) f.print(" "); 2657 return Jlisp.nil; 2658 } 2659 } 2660 2661 class TyoFn extends BuiltinFunction 2662 { op1(LispObject arg1)2663 public LispObject op1(LispObject arg1) throws Exception 2664 { 2665 return error(name + " not yet implemented"); 2666 } 2667 } 2668 2669 class Undouble_executeFn extends BuiltinFunction 2670 { op1(LispObject arg1)2671 public LispObject op1(LispObject arg1) throws Exception 2672 { 2673 return error(name + " not yet implemented"); 2674 } 2675 } 2676 2677 class UnfluidFn extends BuiltinFunction 2678 { op1(LispObject arg1)2679 public LispObject op1(LispObject arg1) throws Exception 2680 { 2681 return error(name + " not yet implemented"); 2682 } 2683 } 2684 2685 class UnglobalFn extends BuiltinFunction 2686 { op1(LispObject arg1)2687 public LispObject op1(LispObject arg1) throws Exception 2688 { 2689 return error(name + " not yet implemented"); 2690 } 2691 } 2692 2693 class UnionFn extends BuiltinFunction 2694 { op2(LispObject arg1, LispObject arg2)2695 public LispObject op2(LispObject arg1, LispObject arg2) throws Exception 2696 { 2697 while (!arg1.atom) 2698 { LispObject a2 = arg2; 2699 while (!a2.atom) 2700 { if (a2.car.lispequals(arg1.car)) break; 2701 a2 = a2.cdr; 2702 } 2703 if (a2.atom) 2704 arg2 = new Cons(arg1.car, arg2); 2705 arg1 = arg1.cdr; 2706 } 2707 return arg2; 2708 } 2709 } 2710 2711 class Unmake_globalFn extends BuiltinFunction 2712 { op1(LispObject arg1)2713 public LispObject op1(LispObject arg1) throws Exception 2714 { 2715 Fns.remprop((Symbol)arg1, Jlisp.lit[Lit.global]); 2716 return Jlisp.nil; 2717 } 2718 } 2719 2720 class Unmake_specialFn extends BuiltinFunction 2721 { op1(LispObject arg1)2722 public LispObject op1(LispObject arg1) throws Exception 2723 { 2724 Fns.remprop((Symbol)arg1, Jlisp.lit[Lit.special]); 2725 return Jlisp.nil; 2726 } 2727 } 2728 2729 class UnreadchFn extends BuiltinFunction 2730 { op1(LispObject arg1)2731 public LispObject op1(LispObject arg1) throws Exception 2732 { 2733 return error(name + " not yet implemented"); 2734 } 2735 } 2736 2737 class UntraceFn extends BuiltinFunction 2738 { op1(LispObject arg1)2739 public LispObject op1(LispObject arg1) throws Exception 2740 { 2741 while (!arg1.atom) 2742 { Symbol n = (Symbol)arg1.car; 2743 if (n.fn instanceof TracedFunction) 2744 n.fn = ((TracedFunction)n.fn).fn; 2745 arg1 = arg1.cdr; 2746 } 2747 return Jlisp.nil; 2748 } 2749 } 2750 2751 class UntracesetFn extends BuiltinFunction 2752 { op1(LispObject arg1)2753 public LispObject op1(LispObject arg1) throws Exception 2754 { 2755 return error(name + " not yet implemented"); 2756 } 2757 } 2758 2759 class Untraceset1Fn extends BuiltinFunction 2760 { op1(LispObject arg1)2761 public LispObject op1(LispObject arg1) throws Exception 2762 { 2763 return error(name + " not yet implemented"); 2764 } 2765 } 2766 2767 class Unwind_protectFn extends BuiltinFunction 2768 { op1(LispObject arg1)2769 public LispObject op1(LispObject arg1) throws Exception 2770 { 2771 return error(name + " not yet implemented"); 2772 } 2773 } 2774 2775 class UpbvFn extends BuiltinFunction 2776 { op1(LispObject arg1)2777 public LispObject op1(LispObject arg1) throws Exception 2778 { 2779 int n; 2780 if (arg1 instanceof LispString) 2781 n = ((LispString)arg1).string.length(); 2782 else if (arg1 instanceof LispVector) 2783 n = ((LispVector)arg1).vec.length; 2784 else return Jlisp.nil; 2785 return LispInteger.valueOf(n-1); 2786 } 2787 } 2788 2789 class User_homedir_pathnameFn extends BuiltinFunction 2790 { op1(LispObject arg1)2791 public LispObject op1(LispObject arg1) throws Exception 2792 { 2793 return error(name + " not yet implemented"); 2794 } 2795 } 2796 2797 class VectorpFn extends BuiltinFunction 2798 { op1(LispObject arg1)2799 public LispObject op1(LispObject arg1) throws Exception 2800 { 2801 if (arg1 instanceof LispVector) return Jlisp.lispTrue; 2802 else return Jlisp.nil; 2803 } 2804 } 2805 2806 class VerbosFn extends BuiltinFunction 2807 { op1(LispObject arg1)2808 public LispObject op1(LispObject arg1) throws Exception 2809 { 2810 int old = Jlisp.verbosFlag; 2811 if (arg1 instanceof LispInteger) 2812 Jlisp.verbosFlag = arg1.intValue(); 2813 else if (arg1 == Jlisp.nil) Jlisp.verbosFlag = 0; 2814 else Jlisp.verbosFlag = 3; 2815 return LispInteger.valueOf(old); 2816 } 2817 } 2818 2819 class Where_was_thatFn extends BuiltinFunction 2820 { op0()2821 public LispObject op0() throws Exception 2822 { 2823 return new Cons( 2824 new LispString("Unknown file"), 2825 new Cons(LispInteger.valueOf(-1), Jlisp.nil)); 2826 } 2827 } 2828 2829 class Window_headingFn extends BuiltinFunction 2830 { op1(LispObject a)2831 public LispObject op1(LispObject a) throws Exception 2832 { 2833 String s; 2834 if (a instanceof Symbol) 2835 { ((Symbol)a).completeName(); 2836 s = ((Symbol)a).pname; 2837 } 2838 else if (a instanceof LispString) s = ((LispString)a).string; 2839 else return Jlisp.nil; 2840 // Note that I just dump this to output with no regard for Lisp output 2841 // streams, buffering etc! 2842 if (Jlisp.standAlone) System.out.println(s); 2843 else 2844 { 2845 // in CWin case put string arg on window title-bar @@@@ 2846 } 2847 return Jlisp.nil; 2848 } 2849 } 2850 2851 class Startup_bannerFn extends BuiltinFunction 2852 { op1(LispObject a)2853 public LispObject op1(LispObject a) throws Exception 2854 { 2855 // reset message displayed when Jlisp starts up @@@@ 2856 // compressed heap images make this harder. I need to worry! 2857 return Jlisp.nil; 2858 } 2859 } 2860 2861 class Writable_librarypFn extends BuiltinFunction 2862 { op1(LispObject arg1)2863 public LispObject op1(LispObject arg1) throws Exception 2864 { 2865 return error(name + " not yet implemented"); 2866 } 2867 } 2868 2869 class Write_help_moduleFn extends BuiltinFunction 2870 { op1(LispObject arg1)2871 public LispObject op1(LispObject arg1) throws Exception 2872 { 2873 return error(name + " not yet implemented"); 2874 } 2875 } 2876 2877 class Write_moduleFn extends BuiltinFunction 2878 { op1(LispObject arg1)2879 public LispObject op1(LispObject arg1) throws Exception 2880 { 2881 if (Fasl.writer == null) 2882 return error("no FASL file active in write-module"); 2883 Fasl.faslWrite(arg1); 2884 return Jlisp.nil; 2885 } 2886 } 2887 2888 class WrsFn extends BuiltinFunction 2889 { op1(LispObject arg1)2890 public LispObject op1(LispObject arg1) 2891 { 2892 // see comments for Rds. 2893 if (arg1 == Jlisp.nil) arg1 = Jlisp.lit[Lit.terminal_io].car/*value*/; 2894 LispObject prev = Jlisp.lit[Lit.std_output].car/*value*/; 2895 Jlisp.lit[Lit.std_output].car/*value*/ = (LispStream)arg1; 2896 return prev; 2897 } 2898 } 2899 2900 class XassocFn extends BuiltinFunction 2901 { op1(LispObject arg1)2902 public LispObject op1(LispObject arg1) throws Exception 2903 { 2904 return error(name + " not yet implemented"); 2905 } 2906 } 2907 2908 class XconsFn extends BuiltinFunction 2909 { op2(LispObject arg1, LispObject arg2)2910 public LispObject op2(LispObject arg1, LispObject arg2) throws ResourceException 2911 { 2912 return new Cons(arg2, arg1); 2913 } 2914 } 2915 2916 class XdifferenceFn extends BuiltinFunction 2917 { op1(LispObject arg1)2918 public LispObject op1(LispObject arg1) throws Exception 2919 { 2920 return error(name + " not yet implemented"); 2921 } 2922 } 2923 2924 class XtabFn extends BuiltinFunction 2925 { op1(LispObject arg1)2926 public LispObject op1(LispObject arg1) throws ResourceException 2927 { 2928 int n = ((LispSmallInteger)arg1).value; 2929 LispStream f = (LispStream)Jlisp.lit[Lit.std_output].car/*value*/; 2930 for (int i=0; i<n; i++) f.print(" "); 2931 return Jlisp.nil; 2932 } 2933 } 2934 2935 class TyiFn extends BuiltinFunction 2936 { op1(LispObject arg1)2937 public LispObject op1(LispObject arg1) throws Exception 2938 { 2939 return error(name + " not yet implemented"); 2940 } 2941 } 2942 2943 2944 } 2945 2946 // end of Fns3.java 2947 2948