1 package uk.co.codemist.jlisp.core;
2 
3 //
4 // This file is part of the Jlisp implementation of Standard Lisp
5 // Copyright \u00a9 (C) Codemist Ltd, 1998-2015.
6 //
7 
8 // Fns.java
9 //
10 // a class that exists solely so that I can place various commonly used
11 // functions as static methods here
12 
13 
14 /**************************************************************************
15  * Copyright (C) 1998-2015, Codemist Ltd.                A C Norman       *
16  *                            also contributions from Vijay Chauhan, 2002 *
17  *                                                                        *
18  * Redistribution and use in source and binary forms, with or without     *
19  * modification, are permitted provided that the following conditions are *
20  * met:                                                                   *
21  *                                                                        *
22  *     * Redistributions of source code must retain the relevant          *
23  *       copyright notice, this list of conditions and the following      *
24  *       disclaimer.                                                      *
25  *     * Redistributions in binary form must reproduce the above          *
26  *       copyright notice, this list of conditions and the following      *
27  *       disclaimer in the documentation and/or other materials provided  *
28  *       with the distribution.                                           *
29  *                                                                        *
30  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
31  * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
32  * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
33  * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
34  * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
35  * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
36  * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
37  * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
38  * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
39  * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
40  * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
41  * DAMAGE.                                                                *
42  *************************************************************************/
43 
44 // $Id: Fns.java 3137 2015-06-15 09:45:01Z arthurcnorman $
45 
46 
47 class Fns
48 {
49     static String prompt = null;
50 
fluid(Symbol s)51     static void fluid(Symbol s) throws ResourceException
52     {
53         put(s, (Symbol)Jlisp.lit[Lit.special], Jlisp.lispTrue);
54         if (s.car/*value*/ == Jlisp.lit[Lit.undefined]) s.car/*value*/ = Jlisp.nil;
55     }
56 
put(Symbol name, Symbol key, LispObject value)57     static LispObject put(Symbol name, Symbol key, LispObject value) throws ResourceException
58     {
59         int f = key.cacheFlags >> 16;
60         if (f != 0)
61         {   LispObject [] v;
62             if ((v = name.fastgets) == null)
63             {   v = new LispObject[63];
64                 for (int i=0; i<63; i++) v[i] = Spid.noprop;
65                 name.fastgets = v;
66             }
67             v[f-1] = value;
68             return value;
69         }
70         LispObject plist = name.cdr/*plist*/;
71         while (!plist.atom)
72 	{   LispObject w = plist;
73             plist = w.cdr;
74             LispObject x = w.car;
75             if (!x.atom && x.car == key)
76             {   x.cdr = value;
77                 return value;
78             }
79         }
80         name.cdr/*plist*/ = new Cons(new Cons(key, value), name.cdr/*plist*/);
81         return value;
82     }
83 
get(Symbol name, Symbol key)84     static LispObject get(Symbol name, Symbol key)
85     {
86         int f = key.cacheFlags >> 16;
87         if (f != 0)
88         {   if (name.fastgets == null) return Jlisp.nil;
89             else
90             {   LispObject w = name.fastgets[f-1];
91                 if (w == Spid.noprop) w = Jlisp.nil;
92                 return w;
93             }
94         }
95         LispObject plist = name.cdr/*plist*/;
96         while (!plist.atom)
97 	{   LispObject w = plist;
98             plist = w.cdr;
99             LispObject x = w.car;
100             if (!x.atom && x.car == key) return x.cdr;
101         }
102         return Jlisp.nil;
103     }
104 
remprop(Symbol name, Symbol key)105     static LispObject remprop(Symbol name, Symbol key)
106     {
107         int f = key.cacheFlags >> 16;
108         if (f != 0)
109         {   LispObject [] v;
110             if ((v = name.fastgets) != null) v[f-1] = Spid.noprop;
111             return Jlisp.nil;
112         }
113         LispObject plist = name.cdr/*plist*/;
114         LispObject prev = null;
115         while (!plist.atom)
116 	{   LispObject w = plist;
117             plist = w.cdr;
118             LispObject x = w.car;
119             if (!x.atom && x.car == key)
120 	    {   if (prev == null) name.cdr/*plist*/ = w.cdr;
121                 else prev.cdr = w.cdr;
122                 return x.cdr;
123             }
124             prev = w;
125         }
126         return Jlisp.nil;
127     }
128 
list2(LispObject a, LispObject b)129     static LispObject list2(LispObject a, LispObject b) throws ResourceException
130     {
131         return new Cons(a, new Cons(b, Jlisp.nil));
132     }
133 
reversip(LispObject arg1)134     static LispObject reversip(LispObject arg1)
135     {
136         LispObject r = Jlisp.nil;
137         while (!arg1.atom)
138 	{   LispObject a = arg1;
139             arg1 = a.cdr;
140             a.cdr = r;
141             r = a;
142         }
143         return r;
144     }
145 
lessp(LispObject arg1, LispObject arg2)146     static LispObject lessp(LispObject arg1, LispObject arg2) throws Exception
147     {
148         return arg1.le(arg2) ? Jlisp.lispTrue : Jlisp.nil;
149     }
150 
151 // The following applyx functions are only ever used when the function
152 // concerned is a lambda-expression (at least it is not a symbol or
153 // function-object). Life is much nastier then one might have dreamt
154 // because I want to cope with &optional and &rest. However I will
155 // NOT (at first?) support supplied-p etc information
156     static LispObject [] args = new LispObject[20];
157     static int argspassed;
158 
apply0(LispObject fn)159     static LispObject apply0(LispObject fn) throws Exception
160     {
161         return applyInner(fn, 0);
162     }
163 
apply1(LispObject fn, LispObject a1)164     static LispObject apply1(LispObject fn, LispObject a1) throws Exception
165     {
166         args[0] = a1;
167         return applyInner(fn, 1);
168     }
169 
apply2(LispObject fn, LispObject a1, LispObject a2)170     static LispObject apply2(LispObject fn, LispObject a1,
171                              LispObject a2) throws Exception
172     {
173         args[0] = a1;
174         args[1] = a2;
175         return applyInner(fn, 2);
176     }
177 
apply3(LispObject fn, LispObject a1, LispObject a2, LispObject a3)178     static LispObject apply3(LispObject fn, LispObject a1,
179                              LispObject a2, LispObject a3) throws Exception
180     {
181         args[0] = a1;
182         args[1] = a2;
183         args[2] = a3;
184         return applyInner(fn, 3);
185     }
186 
applyn(LispObject fn, LispObject [] a)187     static LispObject applyn(LispObject fn, LispObject [] a) throws Exception
188     {
189         for (int i=0; i<a.length; i++) args[i] = a[i];
190         return applyInner(fn, a.length);
191     }
192 
applyInner(LispObject fn, int passed)193     static LispObject applyInner(LispObject fn, int passed) throws Exception
194     {
195         if (fn.atom ||
196             fn.car != Jlisp.lit[Lit.lambda])
197             Jlisp.error("not a function", fn);
198         fn = fn.cdr;
199         LispObject bvl = fn.car;
200         LispObject body = fn.cdr;
201         int nvars = 0, nopts = -1, nrest = -1;
202 // Here I need to detect and handle "&optional" and "&rest"
203         LispObject b;
204         for (b = bvl;
205              !b.atom &&
206              b.car != Jlisp.lit[Lit.optional] &&
207              b.car != Jlisp.lit[Lit.rest];
208              b = b.cdr) nvars++;
209         if (passed < nvars) Jlisp.error("not enough args provided", bvl);
210         for (;!b.atom &&
211              b.car != Jlisp.lit[Lit.rest];
212              b = b.cdr) nopts++;
213         for (;!b.atom;b = b.cdr) nrest++;
214         if (nrest > 1) Jlisp.error("may only have one &rest arg", bvl);
215         if (nopts < 0) nopts = 0;
216         if (nrest < 0) nrest = 0;
217         int total = nvars + nopts;
218         if (nrest==0 && passed > total)
219             Jlisp.error("too many args provided", bvl);
220 // Pad so optional args get nil as their values.
221         for (int i=passed; i<total; i++) args[i] = Jlisp.nil;
222 // collect things that go into "&rest" into a list. Adjust var count
223         if (nrest != 0)
224         {   LispObject r = Jlisp.nil;
225             for (int i=passed-1; i>=total; i--)
226                  r = new Cons(args[i], r);
227             args[total++] = r;
228         }
229         LispObject [] save = new LispObject [total];
230         nvars = 0;
231         for (LispObject b1 = bvl; !b1.atom; b1 = b1.cdr)
232         {   Symbol s = (Symbol)b1.car;
233             if (s == Jlisp.lit[Lit.optional] ||
234                 s == Jlisp.lit[Lit.rest]) continue;
235             save[nvars] = s.car/*value*/;
236             s.car/*value*/ = args[nvars++];
237         }
238         LispObject r = Jlisp.nil;
239         try
240         {   while (!body.atom && Specfn.progEvent == Specfn.NONE)
241             {   r = body.car.eval();
242                 body = body.cdr;
243             }
244         }
245 // restore all bound variables
246         finally
247         {   nvars = 0;
248             for (LispObject b1 = bvl; !b1.atom; b1 = b1.cdr)
249             {   LispObject s = b1.car;
250                 if (s == Jlisp.lit[Lit.optional] ||
251                     s == Jlisp.lit[Lit.rest]) continue;
252                 s.car/*value*/ = save[nvars++];
253             }
254         }
255         return r;
256     }
257 
explodeToString(LispObject arg1)258     static String explodeToString(LispObject arg1) throws Exception
259     {
260         LispStream f = new LispOutputString();
261         LispObject save = Jlisp.lit[Lit.std_output].car/*value*/;
262         try
263         {   Jlisp.lit[Lit.std_output].car/*value*/ = f;
264             arg1.print(LispObject.printEscape);
265         }
266         finally
267         {   Jlisp.lit[Lit.std_output].car/*value*/ = save;
268         }
269         return f.sb.toString();
270     }
271 }
272 
273 // end of Fns.java
274