package uk.co.codemist.jlisp; // // This file is part of the Jlisp implementation of Standard Lisp // Copyright \u00a9 (C) Codemist Ltd, 1998-2011. // // Fns3.java /************************************************************************** * Copyright (C) 1998-2011, Codemist Ltd. A C Norman * * also contributions from Vijay Chauhan, 2002 * * * * Redistribution and use in source and binary forms, with or without * * modification, are permitted provided that the following conditions are * * met: * * * * * Redistributions of source code must retain the relevant * * copyright notice, this list of conditions and the following * * disclaimer. * * * Redistributions in binary form must reproduce the above * * copyright notice, this list of conditions and the following * * disclaimer in the documentation and/or other materials provided * * with the distribution. * * * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS * * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE * * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, * * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, * * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS * * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND * * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR * * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF * * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH * * DAMAGE. * *************************************************************************/ // Each built-in function is created wrapped in a class // that is derived from BuiltinFunction. import java.io.*; import java.util.*; import java.util.zip.*; import java.text.*; import java.math.*; class Fns3 { Object [][] builtins = { {"liter", new LiterFn()}, {"load-module", new Load_moduleFn()}, {"lposn", new LposnFn()}, {"macro-function", new Macro_functionFn()}, {"macroexpand", new MacroexpandFn()}, {"macroexpand-1", new Macroexpand_1Fn()}, {"make-bps", new Make_bpsFn()}, {"make-function-stream", new Make_function_streamFn()}, {"make-global", new Make_globalFn()}, {"make-native", new Make_nativeFn()}, {"make-random-state", new Make_random_stateFn()}, {"make-simple-string", new Make_simple_stringFn()}, {"make-special", new Make_specialFn()}, {"map", new MapFn()}, {"mapc", new MapcFn()}, {"mapcan", new MapcanFn()}, {"mapcar", new MapcarFn()}, {"mapcon", new MapconFn()}, {"maphash", new MaphashFn()}, {"maplist", new MaplistFn()}, {"mapstore", new MapstoreFn()}, {"md5", new Md5Fn()}, {"md60", new Md60Fn()}, {"member", new MemberFn()}, {"member**", new MemberStarStarFn()}, {"memq", new MemqFn()}, {"mkevect", new MkevectFn()}, {"mkfvect32", new Mkfvect32Fn()}, {"mkfvect64", new Mkfvect64Fn()}, {"mkhash", new MkhashFn()}, {"mkquote", new MkquoteFn()}, {"mkvect", new MkvectFn()}, {"mkvect16", new Mkvect16Fn()}, {"mkvect32", new Mkvect32Fn()}, {"mkvect8", new Mkvect8Fn()}, {"mkxvect", new MkxvectFn()}, {"modulep", new ModulepFn()}, {"native-address", new Native_addressFn()}, {"native-getv", new Native_getvFn()}, {"native-putv", new Native_putvFn()}, {"native-type", new Native_typeFn()}, {"nconc", new NconcFn()}, {"ncons", new NconsFn()}, {"neq", new NeqFn()}, {"noisy-setq", new Noisy_setqFn()}, {"not", new NotFn()}, {"null", new NullFn()}, {"oblist", new OblistFn()}, {"oem-supervisor", new Oem_supervisorFn()}, {"open", new OpenFn()}, {"internal-open", new InternalOpenFn()}, {"open-library", new Open_libraryFn()}, {"open-url", new Open_urlFn()}, {"orderp", new OrderpFn()}, {"ordp", new OrderpFn()}, // synonym {"output-library", new Output_libraryFn()}, {"pagelength", new PagelengthFn()}, {"pair", new PairFn()}, {"pairp", new PairpFn()}, {"peekch", new PeekchFn()}, {"pipe-open", new Pipe_openFn()}, {"plist", new PlistFn()}, {"posn", new PosnFn()}, {"preserve", new PreserveFn()}, {"restart-csl", new RestartFn()}, {"saveobject", new SaveObjectFn()}, {"restoreobject", new RestoreObjectFn()}, {"prin", new PrinFn()}, {"prin1", new Prin1Fn()}, {"prin2", new Prin2Fn()}, {"prin2a", new Prin2aFn()}, {"prinbinary", new PrinbinaryFn()}, {"princ", new PrincFn()}, {"princ-downcase", new Princ_downcaseFn()}, {"princ-upcase", new Princ_upcaseFn()}, {"prinhex", new PrinhexFn()}, {"prinoctal", new PrinoctalFn()}, {"print", new PrintFn()}, {"printc", new PrintcFn()}, {"printprompt", new PrintpromptFn()}, {"prog1", new Prog1Fn()}, {"prog2", new Prog2Fn()}, {"progn", new PrognFn()}, {"put", new PutFn()}, {"puthash", new PuthashFn()}, {"putv", new PutvFn()}, {"putv-char", new Putv_charFn()}, {"putv16", new Putv16Fn()}, {"putv32", new Putv32Fn()}, {"putv8", new Putv8Fn()}, {"qcaar", new QcaarFn()}, {"qcadr", new QcadrFn()}, {"qcar", new QcarFn()}, {"qcdar", new QcdarFn()}, {"qcddr", new QcddrFn()}, {"qcdr", new QcdrFn()}, {"qgetv", new QgetvFn()}, {"qputv", new QputvFn()}, {"rassoc", new RassocFn()}, {"rdf", new RdfFn()}, {"rds", new RdsFn()}, {"read", new ReadFn()}, {"readch", new ReadchFn()}, {"readline", new ReadlineFn()}, {"reclaim", new ReclaimFn()}, {"remd", new RemdFn()}, {"remflag", new RemflagFn()}, {"remhash", new RemhashFn()}, {"remob", new RemobFn()}, {"remprop", new RempropFn()}, {"rename-file", new Rename_fileFn()}, {"representation", new RepresentationFn()}, {"return", new ReturnFn()}, {"reverse", new ReverseFn()}, {"reversip", new ReversipFn()}, {"reversip2", new ReversipFn()}, {"nreverse", new ReversipFn()}, {"rplaca", new RplacaFn()}, {"rplacd", new RplacdFn()}, {"rplacw", new RplacwFn()}, {"rseek", new RseekFn()}, {"rtell", new RtellFn()}, {"sample", new SampleFn()}, {"sassoc", new SassocFn()}, {"schar", new ScharFn()}, {"seprp", new SeprpFn()}, {"set", new SetFn()}, {"set-autoload", new Set_autoloadFn()}, {"set-help-file", new Set_help_fileFn()}, {"set-print-precision", new Set_print_precisionFn()}, {"setprintprecision", new Set_print_precisionFn()}, {"getprintprecision", new Get_print_precisionFn()}, {"setpchar", new SetpcharFn()}, {"simple-string-p", new Simple_string_pFn()}, {"simple-vector-p", new Simple_vector_pFn()}, {"smemq", new SmemqFn()}, {"spaces", new SpacesFn()}, {"special-char", new Special_charFn()}, {"special-form-p", new Special_form_pFn()}, {"spool", new SpoolFn()}, {"start-module", new Start_moduleFn()}, {"stop", new StopFn()}, {"streamp", new StreampFn()}, {"stringp", new StringpFn()}, {"stub1", new Stub1Fn()}, {"stub2", new Stub2Fn()}, {"subla", new SublaFn()}, {"sublis", new SublisFn()}, {"subst", new SubstFn()}, {"substq", new SubstqFn()}, {"sxhash", new SxhashFn()}, // equalhash is NOT really sorted out yet since it ought not to // descend through vectors. {"equalhash", new SxhashFn()}, {"symbol-argcount", new Symbol_argcountFn()}, {"symbol-env", new Symbol_envFn()}, {"symbol-fastgets", new Symbol_fastgetsFn()}, {"symbol-fn-cell", new Symbol_fn_cellFn()}, {"symbol-function", new Symbol_functionFn()}, {"symbol-make-fastget", new Symbol_make_fastgetFn()}, {"symbol-name", new Symbol_nameFn()}, {"symbol-protect", new Symbol_protectFn()}, {"symbol-set-definition", new Symbol_set_definitionFn()}, {"symbol-set-env", new Symbol_set_envFn()}, {"symbol-set-native", new Symbol_set_nativeFn()}, {"symbol-value", new Symbol_valueFn()}, {"symbolp", new SymbolpFn()}, {"symerr", new SymerrFn()}, {"system", new SystemFn()}, {"tagbody", new TagbodyFn()}, {"terpri", new TerpriFn()}, {"threevectorp", new ThreevectorpFn()}, {"throw", new ThrowFn()}, {"time", new TimeFn()}, {"tmpnam", new TmpnamFn()}, {"trace", new TraceFn()}, {"traceset", new TracesetFn()}, {"traceset1", new Traceset1Fn()}, {"ttab", new TtabFn()}, {"tyo", new TyoFn()}, {"undouble-execute", new Undouble_executeFn()}, {"unfluid", new UnfluidFn()}, {"unglobal", new UnglobalFn()}, {"union", new UnionFn()}, {"unmake-global", new Unmake_globalFn()}, {"unmake-special", new Unmake_specialFn()}, {"unreadch", new UnreadchFn()}, {"untrace", new UntraceFn()}, {"untraceset", new UntracesetFn()}, {"untraceset1", new Untraceset1Fn()}, {"unwind-protect", new Unwind_protectFn()}, {"upbv", new UpbvFn()}, {"user-homedir-pathname", new User_homedir_pathnameFn()}, {"vectorp", new VectorpFn()}, {"verbos", new VerbosFn()}, {"where-was-that", new Where_was_thatFn()}, {"window-heading", new Window_headingFn()}, {"startup-banner", new Startup_bannerFn()}, {"writable-libraryp", new Writable_librarypFn()}, {"write-help-module", new Write_help_moduleFn()}, {"write-module", new Write_moduleFn()}, {"wrs", new WrsFn()}, {"xassoc", new XassocFn()}, {"xcons", new XconsFn()}, {"xdifference", new XdifferenceFn()}, {"xtab", new XtabFn()}, {"~tyi", new TyiFn()} }; class LiterFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { if (!(arg1 instanceof Symbol)) return Jlisp.nil; Symbol s = (Symbol)arg1; s.completeName(); char ch = s.pname.charAt(0); if (Character.isLetter(ch)) return Jlisp.lispTrue; else return Jlisp.nil; } } class Load_moduleFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return Fasl.loadModule(arg1); } } class LposnFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Macro_functionFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { if (!(arg1 instanceof Symbol)) return Jlisp.nil; LispFunction fn = ((Symbol)arg1).fn; if (fn instanceof Macro) { return ((Macro)fn).body; } else return Jlisp.nil; } } class MacroexpandFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return op2(arg1, null); } public LispObject op2(LispObject arg1, LispObject arg2) throws Exception { for (;;) { if (arg1.atom) return arg1; if (!(arg1.car instanceof Symbol)) return arg1; Symbol f = (Symbol)arg1.car; LispFunction fn = f.fn; if (!(fn instanceof Macro)) return arg1; // At last - here I have a macro that I can expand arg1 = fn.op1(arg1); } } } class Macroexpand_1Fn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return op2(arg1, null); } public LispObject op2(LispObject arg1, LispObject arg2) throws Exception { if (arg1.atom) return arg1; if (!(arg1.car instanceof Symbol)) return arg1; Symbol f = (Symbol)arg1.car; LispFunction fn = f.fn; if (!(fn instanceof Macro)) return arg1; // At last - here I have a macro that I can expand return fn.op1(arg1); } } class Make_bpsFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { int n = ((LispSmallInteger)arg1).value; return new Bytecode(n); } } class Make_function_streamFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Make_globalFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws ResourceException { Symbol s = (Symbol)arg1; Fns.put(s, Jlisp.lit[Lit.global], Jlisp.lispTrue); if (s.car/*value*/ == Jlisp.lit[Lit.undefined]) s.car/*value*/ = Jlisp.nil; return Jlisp.nil; } } class Make_nativeFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Make_random_stateFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Make_simple_stringFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { int n = ((LispSmallInteger)arg1).value; char [] c = new char[n]; for (int i=0; i"); else return r; } } class PrinFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws ResourceException { arg1.print(LispObject.printEscape); return arg1; } } class Prin1Fn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws ResourceException { arg1.print(LispObject.printEscape); return arg1; } } class Prin2Fn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws ResourceException { arg1.print(0); return arg1; } } class Prin2aFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws ResourceException { arg1.print(LispObject.noLineBreak); return arg1; } } class PrinbinaryFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws ResourceException { arg1.print(LispObject.printBinary); return arg1; } } class PrincFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws ResourceException { arg1.print(); return arg1; } } class Princ_downcaseFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws ResourceException { arg1.print(LispObject.printLower); return arg1; } } class Princ_upcaseFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws ResourceException { arg1.print(LispObject.printUpper); return arg1; } } class PrinhexFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws ResourceException { arg1.print(LispObject.printHex); return arg1; } } class PrinoctalFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws ResourceException { arg1.print(LispObject.printOctal); return arg1; } } class PrintFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws ResourceException { arg1.print(LispObject.printEscape); Jlisp.println(); return arg1; } } class PrintcFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws ResourceException { arg1.print(); Jlisp.println(); return arg1; } } class PrintpromptFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Prog1Fn extends BuiltinFunction { public LispObject op0() { return Jlisp.nil; } public LispObject op1(LispObject arg1) { return arg1; } public LispObject op2(LispObject arg1, LispObject arg2) { return arg1; } public LispObject opn(LispObject [] args) { return args[0]; } } class Prog2Fn extends BuiltinFunction { public LispObject op0() { return Jlisp.nil; } public LispObject op1(LispObject arg1) { return Jlisp.nil; } public LispObject op2(LispObject arg1, LispObject arg2) { return arg2; } public LispObject opn(LispObject [] args) { return args[1]; } } class PrognFn extends BuiltinFunction { public LispObject op0() { return Jlisp.nil; } public LispObject op1(LispObject arg1) { return arg1; } public LispObject op2(LispObject arg1, LispObject arg2) { return arg2; } public LispObject opn(LispObject [] args) { return args[args.length-1]; } } class PutFn extends BuiltinFunction { public LispObject opn(LispObject [] args) throws Exception { if (args.length != 3) return error("put called with " + args.length + "args when 3 expected"); return Fns.put((Symbol)args[0], args[1], args[2]); } } class PuthashFn extends BuiltinFunction { public LispObject op2(LispObject key, LispObject value) { ((LispHash)Jlisp.lit[Lit.hashtab]).hash.put(key, value); return value; } public LispObject opn(LispObject [] args) throws Exception { if (args.length != 3) return error("puthash called with " + args.length + "args when 2 or 3 expected"); LispObject key = args[0]; LispHash h = (LispHash)args[1]; LispObject value = args[2]; h.hash.put(key, value); return value; } } class PutvFn extends BuiltinFunction { public LispObject opn(LispObject [] args) throws Exception { if (args.length != 3) return error("putv called with " + args.length + "args when 3 expected"); LispVector v = (LispVector)args[0]; LispSmallInteger n = (LispSmallInteger)args[1]; int i = n.value; v.vec[i] = args[2]; return args[2]; } } class Putv_charFn extends BuiltinFunction { public LispObject opn(LispObject [] args) throws Exception { if (args.length != 3) return error("putv-char called with " + args.length + "args when 3 expected"); String v = ((LispString)args[0]).string; LispSmallInteger n = (LispSmallInteger)args[1]; int i = n.value; char [] v1 = v.toCharArray(); v1[i] = (char)(((LispSmallInteger)args[2]).value); ((LispString)args[0]).string = new String(v1); return args[2]; } } class Putv16Fn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Putv32Fn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Putv8Fn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class QcaarFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { return arg1.car.car; } } class QcadrFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return arg1.cdr.car; } } class QcarFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return arg1.car; } } class QcdarFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return arg1.car.cdr; } } class QcddrFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return arg1.cdr.cdr; } } class QcdrFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return arg1.cdr; } } class QgetvFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) { LispVector v = (LispVector)arg1; return v.vec[((LispSmallInteger)arg2).value]; } } class QputvFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class RassocFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class RdfFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { if (!(arg1 instanceof LispString)) return error("argument for rdf should be a string"); String name = ((LispString)arg1).string; LispObject save = Jlisp.lit[Lit.std_input].car/*value*/; try { Jlisp.lit[Lit.std_input].car/*value*/ = new LispStream( name, new BufferedReader( new FileReader(LispStream.nameConvert(name))), false, true); try { Jlisp.println(); // here I really want the simple READ-EVAL-PRINT // without any messing with any restart function. Jlisp.restarting = false; // just to be ultra-careful! Jlisp.readEvalPrintLoop(true); } finally { ((LispStream)Jlisp.lit[Lit.std_input].car/*value*/).close(); } } catch (FileNotFoundException e) { return error("Unable to read from \"" + name + "\""); } finally { Jlisp.lit[Lit.std_input].car/*value*/ = save; Jlisp.println("+++ end of reading " + name); } return Jlisp.nil; } } class RdsFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { // The issue of what to select if the user says (rds nil) is a bit horrid // here in terms of how it should react with the user also re-setting // or re-binding !*std-input!* and the other related variables. Here I // do something that probably works well enough for REDUCE... if (arg1 == Jlisp.nil) arg1 = Jlisp.lit[Lit.terminal_io].car/*value*/; LispObject prev = Jlisp.lit[Lit.std_input].car/*value*/; Jlisp.lit[Lit.std_input].car/*value*/ = (LispStream)arg1; return prev; } } class ReadFn extends BuiltinFunction { public LispObject op0() throws Exception { LispObject w = Jlisp.lit[Lit.eof]; try { w = Jlisp.read(); } catch (EOFException e) { return Jlisp.lit[Lit.eof]; } catch (IOException e) { Jlisp.errprintln("Reader error: " + e.getMessage()); } return w; } } class ReadchFn extends BuiltinFunction { public LispObject op0() throws Exception { try { int ch; do { ch = ((LispStream)Jlisp.lit[Lit.std_input].car/*value*/ ).readChar(); } while (ch == '\r'); // wary of Windows (& DOS) if (ch < 0) return Jlisp.lit[Lit.eof]; else if (ch < 128) return Jlisp.chars[ch]; else return Symbol.intern(String.valueOf((char)ch)); } catch (IOException e) { return error("IO error detected in readch"); } } } class ReadlineFn extends BuiltinFunction { public LispObject op0() throws Exception { StringBuffer s = new StringBuffer(); LispObject sr = Jlisp.lit[Lit.raise].car/*value*/; LispObject sl = Jlisp.lit[Lit.lower].car/*value*/; Jlisp.lit[Lit.raise].car/*value*/ = Jlisp.nil; Jlisp.lit[Lit.lower].car/*value*/ = Jlisp.nil; try { int c; boolean any = false; LispStream r = (LispStream)Jlisp.lit[Lit.std_input].car/*value*/; while ((c = r.readChar()) != '\n' && c != -1) { if (c != '\r') { s.append((char)c); any = true; } } if (c == -1 && !any) return Jlisp.lit[Lit.eof]; else return new LispString(new String(s)); } catch (IOException e) { return error("IO error detected in readline"); } finally { Jlisp.lit[Lit.raise].car/*value*/ = sr; Jlisp.lit[Lit.lower].car/*value*/ = sl; } } public LispObject op1(LispObject a1) throws Exception { StringBuffer s = new StringBuffer(); LispObject sr = Jlisp.lit[Lit.raise].car/*value*/; LispObject sl = Jlisp.lit[Lit.lower].car/*value*/; Jlisp.lit[Lit.raise].car/*value*/ = Jlisp.nil; Jlisp.lit[Lit.lower].car/*value*/ = Jlisp.nil; try { int c; boolean any = false; LispStream r = (LispStream)a1; while ((c = r.readChar()) != '\n' && c != -1) { if (c != '\r') { s.append((char)c); any = true; } } if (c == -1 && !any) return Jlisp.lit[Lit.eof]; else return new LispString(new String(s)); } catch (IOException e) { return error("IO error detected in readline"); } finally { Jlisp.lit[Lit.raise].car/*value*/ = sr; Jlisp.lit[Lit.lower].car/*value*/ = sl; } } } class ReclaimFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class RemdFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { Symbol a = (Symbol)arg1; a.completeName(); a.fn = new Undefined(a.pname); return a; } } class RemflagFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) { while (!arg1.atom) { LispObject p = arg1; Symbol s = (Symbol)p.car; arg1 = p.cdr; Fns.remprop(s, arg2); } return Jlisp.nil; } } class RemhashFn extends BuiltinFunction { public LispObject op1(LispObject key) { LispObject r = (LispObject) ((LispHash)Jlisp.lit[Lit.hashtab]).hash.remove(key); if (r == null) r = Jlisp.nil; return r; } public LispObject op2(LispObject key, LispObject table) { LispHash h = (LispHash)table; LispObject r = (LispObject)h.hash.remove(key); if (r == null) r = Jlisp.nil; return r; } public LispObject opn(LispObject [] args) throws Exception { if (args.length != 3) return error("remhash called with " + args.length + "args when 1 to 3 expected"); LispObject key = args[0]; LispHash h = (LispHash)args[1]; LispObject defaultValue = args[2]; LispObject r = (LispObject)h.hash.remove(key); if (r == null) r = defaultValue; return r; } } class RemobFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { if (arg1 instanceof Symbol) Symbol.remob((Symbol)arg1); return arg1; } } class RempropFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) throws Exception { if (!(arg1 instanceof Symbol)) return Jlisp.nil; else return Fns.remprop((Symbol)arg1, arg2); } } class Rename_fileFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) throws Exception { String s; if (arg1 instanceof Symbol) { ((Symbol)arg1).completeName(); s = ((Symbol)arg1).pname; } else if (arg1 instanceof LispString) s = ((LispString)arg1).string; else return Jlisp.nil; String s1; if (arg2 instanceof Symbol) { ((Symbol)arg1).completeName(); s1 = ((Symbol)arg2).pname; } else if (arg2 instanceof LispString) s1 = ((LispString)arg2).string; else return Jlisp.nil; return LispStream.fileRename(s, s1); } } class RepresentationFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class ReturnFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws ProgEvent { Specfn.progEvent = Specfn.RETURN; Specfn.progData = arg1; return arg1; } } class ReverseFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws ResourceException { LispObject r = Jlisp.nil; while (!arg1.atom) { LispObject a = arg1; r = new Cons(a.car, r); arg1 = a.cdr; } return r; } } class ReversipFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { LispObject r = Jlisp.nil; while (!arg1.atom) { LispObject a = arg1; arg1 = a.cdr; a.cdr = r; r = a; } return r; } public LispObject op2(LispObject arg1, LispObject arg2) { LispObject r = arg2; while (!arg1.atom) { LispObject a = arg1; arg1 = a.cdr; a.cdr = r; r = a; } return r; } } class RplacaFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) throws Exception { if (arg1.atom) return error("bad arg to rplaca"); arg1.car = arg2; return arg1; } } class RplacdFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) throws Exception { if (arg1.atom) return error("bad arg to rplacd"); arg1.cdr = arg2; return arg1; } } class RplacwFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) throws Exception { if (arg1.atom || arg2.atom) return error("bad arg to rplacw"); arg1.car = arg2.car; arg1.cdr = arg2.cdr; return arg1; } } class RseekFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class RtellFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class SampleFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class SassocFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class ScharFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) { int n = ((LispSmallInteger)arg2).value; String s = ((LispString)arg1).string; char ch = s.charAt(n); if (ch < 128) return Jlisp.chars[ch]; else return Symbol.intern(String.valueOf((char)ch)); } } class SeprpFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { // blank end-of-line tab form-fee carriage-return if (arg1 == Jlisp.lit[Lit.space] || arg1 == Jlisp.lit[Lit.newline] || arg1 == Jlisp.lit[Lit.tab] || arg1 == Jlisp.lit[Lit.formFeed] || arg1 == Jlisp.lit[Lit.cr]) return Jlisp.lispTrue; else return Jlisp.nil; } } class SetFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) { ((Symbol)arg1).car/*value*/ = arg2; return arg2; } } class Set_autoloadFn extends BuiltinFunction { public LispObject op2(LispObject name, LispObject data) throws Exception { Symbol f = (Symbol)name; if (data.atom) data = new Cons(data, Jlisp.nil); f.fn = new AutoLoad(f, data); return name; } } class Set_help_fileFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Set_print_precisionFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { int n = Jlisp.printprec; Jlisp.printprec = ((LispSmallInteger)arg1).value; return LispInteger.valueOf(n); } } class Get_print_precisionFn extends BuiltinFunction { public LispObject op0() throws Exception { return LispInteger.valueOf(Jlisp.printprec); } } class SetpcharFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { String old = Fns.prompt; if (old == null) old = ""; // just in case! if (arg1 instanceof LispString) Fns.prompt = ((LispString)arg1).string; else if (arg1 instanceof Symbol) { ((Symbol)arg1).completeName(); Fns.prompt = ((Symbol)arg1).pname; } else Fns.prompt = null; // use system default return new LispString(old); } } class Simple_string_pFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { if (arg1 instanceof LispString) return Jlisp.lispTrue; else return Jlisp.nil; } } class Simple_vector_pFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { if (arg1 instanceof LispVector) return Jlisp.lispTrue; else return Jlisp.nil; } } class SmemqFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) throws Exception { while (!arg2.atom) { LispObject a = arg2; if (a.car == Jlisp.lit[Lit.quote]) return Jlisp.nil; else if (op2(arg1, a.car) != Jlisp.nil) return Jlisp.lispTrue; else arg2 = a.cdr; } if (arg1 == arg2) return Jlisp.lispTrue; else return Jlisp.nil; } } class SpacesFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws ResourceException { int n = ((LispSmallInteger)arg1).value; for (int i=0; i> 8; int flagbits = nopts >> 8; int ntail = flagbits >> 2; nargs &= 0xff; nopts &= 0xff; flagbits &= 0x03; // The next few cases are where a function is defined as a direct call // to another, possibly discarding a few final args. Eg // (de f (a b) (g a)) if (ntail != 0) { a1.fn = new CallAs(nargs, a2.cdr.cdr, ntail-1); return arg1; } a2 = a2.cdr; if (a2.atom) return Jlisp.nil; Bytecode b = (Bytecode)a2.car; LispVector v = (LispVector)a2.cdr; if (flagbits != 0 || nopts != 0) { // What is happening here is a MESS inherited from CSL. // nopts = number of optional args wanted // flagbits & 1 "hard case": pass Spid.noarg not nil for missing opts // flagbits & 2 &rest arg present b = new ByteOpt(b.bytecodes, v.vec, nargs, nopts, flagbits); } else { b.env = v.vec; b.nargs = nargs; } a1.fn = b; return arg1; } // Otherwise drop through and moan } else if (arg2 instanceof Symbol) { Symbol a2 = (Symbol)arg2; a1.fn = a2.fn; return arg1; } else if (arg2 instanceof LispFunction) { a1.fn = (LispFunction)arg2; return arg1; } // Unrecognised cases follow - just print a message Jlisp.println(); arg1.print(LispObject.printEscape); Jlisp.print(" => "); arg2.print(); Jlisp.println(); return Jlisp.nil; } } class Symbol_set_envFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) throws Exception { if (!(arg1 instanceof Symbol)) return Jlisp.nil; LispFunction f = ((Symbol)arg1).fn; if (f instanceof FnWithEnv) ((FnWithEnv)f).env = ((LispVector)arg2).vec; else return Jlisp.nil; // quiet in case it fails? return arg2; } } class Symbol_set_nativeFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Symbol_valueFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { return ((Symbol)arg1).car/*value*/; } } class SymbolpFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return arg1 instanceof Symbol ? Jlisp.lispTrue : Jlisp.nil; } } class SymerrFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class SystemFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { try { Runtime r = Runtime.getRuntime(); r.exec(((LispString)arg1).string); } catch (IOException e) { return Jlisp.nil; } catch (SecurityException e) { return Jlisp.nil; } return Jlisp.lispTrue; } } class TagbodyFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class TerpriFn extends BuiltinFunction { public LispObject op0() throws ResourceException { Jlisp.println(); return Jlisp.nil; } } class ThreevectorpFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { if (arg1 instanceof LispVector && ((LispVector)arg1).vec.length == 3) return Jlisp.lispTrue; else return Jlisp.nil; } } class ThrowFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class TimeFn extends BuiltinFunction { public LispObject op0() throws Exception { return LispInteger.valueOf(System.currentTimeMillis()); } } class TmpnamFn extends BuiltinFunction { public LispObject op0() throws Exception { // Not really satisfactory - but I hope that nobody uses this! return new LispString("tempfile.tmp"); } public LispObject op1(LispObject arg1) throws Exception { String s; if (arg1 instanceof Symbol) { ((Symbol)arg1).completeName(); s = ((Symbol)arg1).pname; } else if (arg1 instanceof LispString) s = ((LispString)arg1).string; else s = "tmp"; return new LispString("tempfile." + s); } } class TraceFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { while (!arg1.atom) { Symbol n = (Symbol)arg1.car; if (!(n.fn instanceof TracedFunction)) n.fn = new TracedFunction(n, n.fn); arg1 = arg1.cdr; } return Jlisp.nil; } } class TracesetFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Traceset1Fn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class TtabFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws ResourceException { int n = ((LispSmallInteger)arg1).value; LispStream f = (LispStream)Jlisp.lit[Lit.std_output].car/*value*/; while (f.column < n) f.print(" "); return Jlisp.nil; } } class TyoFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Undouble_executeFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class UnfluidFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class UnglobalFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class UnionFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) throws Exception { while (!arg1.atom) { LispObject a2 = arg2; while (!a2.atom) { if (a2.car.lispequals(arg1.car)) break; a2 = a2.cdr; } if (a2.atom) arg2 = new Cons(arg1.car, arg2); arg1 = arg1.cdr; } return arg2; } } class Unmake_globalFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { Fns.remprop((Symbol)arg1, Jlisp.lit[Lit.global]); return Jlisp.nil; } } class Unmake_specialFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { Fns.remprop((Symbol)arg1, Jlisp.lit[Lit.special]); return Jlisp.nil; } } class UnreadchFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class UntraceFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { while (!arg1.atom) { Symbol n = (Symbol)arg1.car; if (n.fn instanceof TracedFunction) n.fn = ((TracedFunction)n.fn).fn; arg1 = arg1.cdr; } return Jlisp.nil; } } class UntracesetFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Untraceset1Fn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Unwind_protectFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class UpbvFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { int n; if (arg1 instanceof LispString) n = ((LispString)arg1).string.length(); else if (arg1 instanceof LispVector) n = ((LispVector)arg1).vec.length; else return Jlisp.nil; return LispInteger.valueOf(n-1); } } class User_homedir_pathnameFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class VectorpFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { if (arg1 instanceof LispVector) return Jlisp.lispTrue; else return Jlisp.nil; } } class VerbosFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { int old = Jlisp.verbosFlag; if (arg1 instanceof LispInteger) Jlisp.verbosFlag = arg1.intValue(); else if (arg1 == Jlisp.nil) Jlisp.verbosFlag = 0; else Jlisp.verbosFlag = 3; return LispInteger.valueOf(old); } } class Where_was_thatFn extends BuiltinFunction { public LispObject op0() throws Exception { return new Cons( new LispString("Unknown file"), new Cons(LispInteger.valueOf(-1), Jlisp.nil)); } } class Window_headingFn extends BuiltinFunction { public LispObject op1(LispObject a) throws Exception { String s; if (a instanceof Symbol) { ((Symbol)a).completeName(); s = ((Symbol)a).pname; } else if (a instanceof LispString) s = ((LispString)a).string; else return Jlisp.nil; // Note that I just dump this to output with no regard for Lisp output // streams, buffering etc! if (Jlisp.standAlone) System.out.println(s); else { // in CWin case put string arg on window title-bar @@@@ } return Jlisp.nil; } } class Startup_bannerFn extends BuiltinFunction { public LispObject op1(LispObject a) throws Exception { // reset message displayed when Jlisp starts up @@@@ // compressed heap images make this harder. I need to worry! return Jlisp.nil; } } class Writable_librarypFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Write_help_moduleFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Write_moduleFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { if (Fasl.writer == null) return error("no FASL file active in write-module"); Fasl.faslWrite(arg1); return Jlisp.nil; } } class WrsFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { // see comments for Rds. if (arg1 == Jlisp.nil) arg1 = Jlisp.lit[Lit.terminal_io].car/*value*/; LispObject prev = Jlisp.lit[Lit.std_output].car/*value*/; Jlisp.lit[Lit.std_output].car/*value*/ = (LispStream)arg1; return prev; } } class XassocFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class XconsFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) throws ResourceException { return new Cons(arg2, arg1); } } class XdifferenceFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class XtabFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws ResourceException { int n = ((LispSmallInteger)arg1).value; LispStream f = (LispStream)Jlisp.lit[Lit.std_output].car/*value*/; for (int i=0; i