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