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