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