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