Artifact 93441d9435a64adfc3bd89a9d8a0e4a6e1b543bd0e6f07d8d29c06e3d4dc050d:
- Executable file
r37/lisp/csl/jlisp/Fns3.java
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 82048) [annotate] [blame] [check-ins using] [more...]
// // This file is part of the Jlisp implementation of Standard Lisp // Copyright \u00a9 (C) Codemist Ltd, 1998-2000. // // Fns3.java // 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()}, {"~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()}, {"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()}, {"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()}, {"sxhash", 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; 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) { 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<n; i++) c[i] = (char)0; return new LispString(new String(c)); } } class Make_specialFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { Symbol s = (Symbol)arg1; Fns.put(s, Jlisp.lit[Lit.special], Jlisp.lispTrue); if (s.car/*value*/ == Jlisp.lit[Lit.undefined]) s.car/*value*/ = Jlisp.nil; return Jlisp.nil; } } class MapFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class MapcFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class MapcanFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class MapcarFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class MapconFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class MaphashFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class MaplistFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class MapstoreFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { Jlisp.println(); Jlisp.println("*** MAPSTORE ***"); return Jlisp.nil; } } class Md5Fn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { LispStream f = new LispDigester(); LispObject save = Jlisp.lit[Lit.std_output].car/*value*/; try { Jlisp.lit[Lit.std_output].car/*value*/ = f; arg1.print(LispObject.noLineBreak+LispObject.printEscape); } finally { Jlisp.lit[Lit.std_output].car/*value*/ = save; } byte [] res = f.md.digest(); return LispInteger.valueOf(new BigInteger(res)); } } class Md60Fn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { LispStream f = new LispDigester(); LispObject save = Jlisp.lit[Lit.std_output].car/*value*/; try { Jlisp.lit[Lit.std_output].car/*value*/ = f; arg1.print(LispObject.noLineBreak+LispObject.printEscape); } finally { Jlisp.lit[Lit.std_output].car/*value*/ = save; } byte [] res = f.md.digest(); return LispInteger.valueOf(new BigInteger(res).shiftRight(68)); } } class MemberFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) { while (!arg2.atom) { if (arg1.lispequals(arg2.car)) return arg2; arg2 = arg2.cdr; } return Jlisp.nil; } } class MemberStarStarFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) { while (!arg2.atom) { if (arg1.lispequals(arg2.car)) return arg2; arg2 = arg2.cdr; } return Jlisp.nil; } } class MemqFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) throws Exception { while (!arg2.atom) { if (arg1 instanceof LispNumber) // @@@ { if (arg1.lispequals(arg2.car)) return arg2; // @@@ } // @@@ else if (arg1 == arg2.car) return arg2; arg2 = arg2.cdr; } return Jlisp.nil; } } class MkevectFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Mkfvect32Fn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Mkfvect64Fn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class MkhashFn extends BuiltinFunction { // (MKHASH size flavour growth-ratio) // size is initial table size // flavour: 0 EQ // 1 EQL // 2 EQUAL // 3 EQUALS // 4 EQUALP // ratio: amount to expand by as table gets full // // In this Java version I will ignore the first and third args, // and only support EQ and EQUAL tables! Note that an EQ table // will generally re-hash itself if serialized... public LispObject opn(LispObject [] args) throws Exception { if (args.length != 3) return error("mkhash called with " + args.length + "args when 3 expected"); int n = ((LispSmallInteger)args[1]).value; HashMap h; if (n == 0) h = new HashMap(); else h = new LispEqualHash(); return new LispHash(h, n); } } class MkquoteFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return new Cons(Jlisp.lit[Lit.quote], new Cons(arg1, Jlisp.nil)); } } class MkvectFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { int n = ((LispSmallInteger)arg1).value; return new LispVector(n+1); // Hah - index values from 0 to n } } class Mkvect16Fn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Mkvect32Fn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Mkvect8Fn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class MkxvectFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class ModulepFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { String s; if (arg1 instanceof Symbol) s = ((Symbol)arg1).pname; else if (arg1 instanceof LispString) s = ((LispString)arg1).string; else return error("illegal arg to modulep", arg1); s = s + ".fasl"; for (int i=0; i<Jlisp.imageCount; i++) { arg1 = Jlisp.images[i].modulep(s); if (arg1 != Jlisp.nil) return arg1; } return Jlisp.nil; } } class Native_addressFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Native_getvFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Native_putvFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Native_typeFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class NconcFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) throws Exception { if (arg1.atom) return arg2; LispObject r = arg1; LispObject prev = null; while (!arg1.atom) { prev = arg1; arg1 = prev.cdr; } prev.cdr = arg2; return r; } } class NconsFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { return new Cons(arg1, Jlisp.nil); } } class NeqFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) { if (arg1 == arg2) return Jlisp.nil; return arg1.lispequals(arg2) ? Jlisp.nil : Jlisp.lispTrue; } } class Noisy_setqFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class NotFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { return arg1 == Jlisp.nil ? Jlisp.lispTrue : Jlisp.nil; } } class NullFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { return arg1 == Jlisp.nil ? Jlisp.lispTrue : Jlisp.nil; } } class OblistFn extends BuiltinFunction { public LispObject op0() { // Note that this implementation pushes out the object list with // items in a randomish order. CSL sorted it which was nice - to do that // here I would have to implement a sorting function, and as present that // does not seem my highest priority. LispObject r = Jlisp.nil; for (int i=0; i<Jlisp.oblistSize; i++) { Symbol w = Jlisp.oblist[i]; if (w != null) { if (w.car/*value*/ != Jlisp.lit[Lit.undefined] || w.cdr/*plist*/ != Jlisp.nil || w.special != null || !(w.fn instanceof Undefined)) r = new Cons(w, r); } } return r; } } class Oem_supervisorFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class OpenFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) throws Exception { if (!(arg1 instanceof LispString)) return error("argument 1 to open must be a string"); String name = ((LispString)arg1).string; if (arg2 == Jlisp.lit[Lit.input]) { LispObject r = Jlisp.nil; try { r = new LispStream( name, new BufferedReader( new FileReader(LispStream.nameConvert(name))), false, true); } catch (FileNotFoundException e) { return error("File " + name + " not found"); } return r; } else if (arg2 == Jlisp.lit[Lit.output]) { LispObject r = Jlisp.nil; try { r = new LispOutputStream(name); } catch (IOException e) { return error("File " + name + " can not be opened for output"); } return r; } else if (arg2 == Jlisp.lit[Lit.append]) { LispObject r = Jlisp.nil; try { r = new LispOutputStream(name, true); } catch (IOException e) { return error("File " + name + " can not be opened for output"); } return r; } else return error( "argument 2 to open should be input, output or append"); } } // The system-coded primitive function ~OPEN opens a file, and takes a second // argument that shows what options are wanted. See extracts from the CSL // file "print.c" (included just below this comment) for an explanation // of the bits. // // This stuff is here so I can be almost ridiculously compatible with CSL // since that makes it easier to share files with that world... // //(de open (a b) // (cond // ((eq b 'input) (!~open a (plus 1 64))) % if-does-not-exist error // ((eq b 'output) (!~open a (plus 2 20 32))) % if-does-not-exist create, // % if-exists new-version // ((eq b 'append) (!~open a (plus 2 8 32))) % if-exists append // (t (error "bad direction ~A in open" b)))) // //(de binopen (a b) // (cond // ((eq b 'input) (!~open a (plus 1 64 128))) // ((eq b 'output) (!~open a (plus 2 20 32 128))) // ((eq b 'append) (!~open a (plus 2 8 32 128))) // (t (error "bad direction ~A in binopen" b)))) // //(de pipe!-open (c d) // (cond // ((eq d 'input) (!~open c (plus 1 256))) // ((eq d 'output) (!~open c (plus 2 256))) // (t (error "bad direction ~A in pipe-open" d)))) // // ///* // * The Common Lisp keywords for OPEN are a horrid mess. I arrange to decode // * the syntax of the keywords in a Lisp-coded wrapper function, and in that // * code I will also fill in default values for any that needs same. I then // * pack all the information into a single integer, which has several // * sub-fields // * // * x x xx xxx 00 direction PROBE // * x x xx xxx 01 INPUT // * x x xx xxx 10 OUTPUT // * x x xx xxx 11 IO // * // * x x xx 000 xx if-exists NIL // * x x xx 001 xx overwrite // * x x xx 010 xx append // * x x xx 011 xx rename // * x x xx 100 xx error // * x x xx 101 xx (new-version) // * x x xx 110 xx (supersede) // * x x xx 111 xx (rename-and-delete) // * // * x x 00 xxx xx if-does-not-exist NIL // * x x 01 xxx xx create // * x x 10 xxx xx error // * // * x 0 xx xxx xx regular text file // * x 1 xx xxx xx open for binary access // * // * 0 x xx xxx xx regular file // * 1 x xx xxx xx open as a pipe // */ // //#define DIRECTION_MASK 0x3 //#define DIRECTION_PROBE 0x0 //#define DIRECTION_INPUT 0x1 //#define DIRECTION_OUTPUT 0x2 //#define DIRECTION_IO 0x3 //#define IF_EXISTS_MASK 0x1c //#define IF_EXISTS_NIL 0x00 //#define IF_EXISTS_OVERWRITE 0x04 //#define IF_EXISTS_APPEND 0x08 //#define IF_EXISTS_RENAME 0x0c //#define IF_EXISTS_ERROR 0x10 //#define IF_EXISTS_NEW_VERSION 0x14 //#define IF_EXISTS_SUPERSEDE 0x18 //#define IF_EXISTS_RENAME_AND_DELETE 0x1c //#define IF_MISSING_MASK 0x60 //#define IF_MISSING_NIL 0x00 //#define IF_MISSING_CREATE 0x20 //#define IF_MISSING_ERROR 0x40 //#define OPEN_BINARY 0x80 //#define OPEN_PIPE 0x100 class InternalOpenFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) throws Exception { if (!(arg1 instanceof LispString)) return error("argument 1 to ~open must be a string"); String name = ((LispString)arg1).string; int bits = ((LispSmallInteger)arg2).value; if ((bits & 0x100) != 0) return openPipe(name, bits); String localName = LispStream.nameConvert(name); File f = new File(localName); boolean x = f.exists(); LispObject r; switch (bits & 3) { case 0: // probe if (x) return Jlisp.lispTrue; else return Jlisp.nil; case 1: // read if (!x) { switch (bits & 0x60) { case 0x00: return Jlisp.nil; case 0x40: return Jlisp.error("File does not exist: " + name); default: return Jlisp.error("File open mode unknown " + Integer.toHexString(bits)); } } r = Jlisp.nil; try { r = new LispStream( name, new BufferedReader( new FileReader(f)), false, true); } catch (FileNotFoundException e) // should not happen! { return error("File " + name + " not found"); } return r; case 2: // write r = Jlisp.nil; try { if (x) { switch (bits & 0x1c) { case 0x00: return Jlisp.nil; case 0x14: // new version: treat as overwrite... case 0x04: return new LispOutputStream(f); // the "append" option seems to have to be opened based on a String not a File case 0x08: return new LispOutputStream(localName, true); case 0x10: return error("File already exists: " + name); default: return error("Unsupported file open mode: " + Integer.toHexString(bits)); } } else r = new LispOutputStream(f); } catch (IOException e) { return Jlisp.nil; } return r; case 3: // input and output return error("simultaneous input+output mode files not supported"); } return Jlisp.nil; } public LispObject openPipe(String name, int bits) throws Exception { return error("pipes not supported by Java, it seems?"); } } class Open_libraryFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Open_urlFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class OrderpFn extends BuiltinFunction { // symbolic procedure ordp(u,v); // if null u then null v // else if null v then t // else if vectorp u then if vectorp v then ordpv(u,v) else atom v // else if atom u // then if atom v // then if numberp u then numberp v and not u<v // else if idp v then orderp(u,v) // else numberp v // else nil // else if atom v then t // else if car u=car v then ordp(cdr u,cdr v) // else if flagp(car u,'noncom) // then if flagp(car v,'noncom) then ordp(car u,car v) else t // else if flagp(car v,'noncom) then nil // else ordp(car u,car v); // public LispObject op2(LispObject u, LispObject v) throws Exception { if (ordp(u,v)) return Jlisp.lispTrue; else return Jlisp.nil; } boolean ordp(LispObject u, LispObject v) throws Exception { if (u == Jlisp.nil) return (v == Jlisp.nil); else if (v == Jlisp.nil) return true; else if (u instanceof LispVector) { if (v instanceof LispVector) return ordv((LispVector)u, (LispVector)v); else return v.atom; } else if (u.atom) { if (v.atom) { if (u instanceof LispNumber) { if (!(v instanceof LispNumber)) return false; return (Fns.lessp(u, v) == Jlisp.nil); } else if (v instanceof Symbol) { if (!(u instanceof Symbol)) return false; return ((Symbol)u).pname.compareTo( ((Symbol)v).pname) <= 0; } else return (v instanceof LispNumber); } else return false; } else if (v.atom) return true; LispObject cu = u, cv = v; LispObject caru = cu.car, carv = cv.car; if (caru.lispequals(carv)) return ordp(cu.cdr, cv.cdr); else if (Fns.get(caru, Jlisp.lit[Lit.noncom]) != Jlisp.nil) { if (Fns.get(carv, Jlisp.lit[Lit.noncom]) != Jlisp.nil) return ordp(caru, carv); else return true; } else if (Fns.get(carv, Jlisp.lit[Lit.noncom]) != Jlisp.nil) return false; else return ordp(caru, carv); } boolean ordv(LispVector u, LispVector v) { return false; } } class Output_libraryFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class PagelengthFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class PairFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) throws Exception { if (!arg1.atom) { if (!arg2.atom) { return new Cons( new Cons(arg1.car, arg2.car), op2(arg1.cdr, arg2.cdr)); } else return error("arg2 to pair is too short"); } else if (!arg2.atom) return error("arg2 to pair is too long"); else return Jlisp.nil; } } class PairpFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return arg1.atom ? Jlisp.nil : Jlisp.lispTrue; } } class PeekchFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Pipe_openFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class PlistFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { return ((Symbol)arg1).cdr/*plist*/; } } class PosnFn extends BuiltinFunction { public LispObject op0() throws Exception { int n = ((LispStream) Jlisp.lit[Lit.std_output].car/*value*/).column; return LispInteger.valueOf(n); } } class RestartFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { Jlisp.backtrace = false; throw new ProgEvent(ProgEvent.RESTART, arg1, "restart"); } public LispObject op2(LispObject arg1, LispObject arg2) throws Exception { Jlisp.backtrace = false; throw new ProgEvent(ProgEvent.RESTART, arg1, arg2, "restart"); } } // (preserve [restartfn [initmsg]]) // dumps all state to a file specifed // as "-o xxx.img" on the initial command-line. class PreserveFn extends BuiltinFunction { public LispObject op0() throws Exception { return op2(Jlisp.nil, Jlisp.nil); } public LispObject op1(LispObject arg1) throws Exception { return op2(arg1, Jlisp.nil); } public LispObject op2(LispObject arg1, LispObject arg2) throws Exception { // Following the tradition from CSL when the user calls PRESERVE the // system stops. This makes more sense than one might have thought since // in the process of unwinding (via the ProgEvent you see here) all fluid // variables are put back to their top level values. If I checkpointed // the system more directly various local bindings might be captured, and // I think that would be undesirable. if (Jlisp.outputImagePos < 0) return Jlisp.error("No output image available"); Jlisp.backtrace = false; throw new ProgEvent(ProgEvent.PRESERVE, new Cons(arg1, arg2), "preserve"); } } class SaveObjectFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) throws Exception { String name = ((LispString)arg1).string; GZIPOutputStream dump = null; try { dump = new GZIPOutputStream( new BufferedOutputStream( new FileOutputStream(name), 32768)); Jlisp.dumpTree(arg2, dump); } catch (IOException e) { Jlisp.errprintln("IO error on dump file: " + e.getMessage()); } finally { if (dump != null) dump.close(); } return Jlisp.nil; } } class RestoreObjectFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return op2(arg1, LispInteger.valueOf(1)); } public LispObject op2(LispObject arg1, LispObject arg2) throws Exception { String name = ((LispString)arg1).string; // read item number n from the file concerned. Used to debug! int n = ((LispSmallInteger)arg2).value; LispObject r = Jlisp.nil; Jlisp.idump = null; try { GZIPInputStream dump = new GZIPInputStream( new BufferedInputStream( new FileInputStream(name), 32768)); Jlisp.idump = dump; Jlisp.preRestore(); Jlisp.descendSymbols = false; for (int i=0; i<n; i++) r = Jlisp.readObject(); } catch (IOException e) { Jlisp.errprintln("IO error on dump file: " + e.getMessage()); } finally { if (Jlisp.idump != null) Jlisp.idump.close(); Jlisp.postRestore(); } if (r == null) return new LispString("<null>"); else return r; } } class PrinFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { arg1.print(LispObject.printEscape); return arg1; } } class Prin1Fn extends BuiltinFunction { public LispObject op1(LispObject arg1) { arg1.print(LispObject.printEscape); return arg1; } } class Prin2Fn extends BuiltinFunction { public LispObject op1(LispObject arg1) { arg1.print(0); return arg1; } } class Prin2aFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { arg1.print(LispObject.noLineBreak); return arg1; } } class PrinbinaryFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { arg1.print(LispObject.printBinary); return arg1; } } class PrincFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { arg1.print(); return arg1; } } class Princ_downcaseFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { arg1.print(LispObject.printLower); return arg1; } } class Princ_upcaseFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { arg1.print(LispObject.printUpper); return arg1; } } class PrinhexFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { arg1.print(LispObject.printHex); return arg1; } } class PrinoctalFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { arg1.print(LispObject.printOctal); return arg1; } } class PrintFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { arg1.print(LispObject.printEscape); Jlisp.println(); return arg1; } } class PrintcFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { 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.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 { return error(name + " not yet implemented"); } } 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) s = ((Symbol)arg1).pname; else if (arg1 instanceof LispString) s = ((LispString)arg1).string; else return Jlisp.nil; String s1; if (arg2 instanceof Symbol) 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) { 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; } } 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 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) 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) { int n = ((LispSmallInteger)arg1).value; for (int i=0; i<n; i++) Jlisp.print(" "); return Jlisp.nil; } } class Special_charFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { LispSmallInteger a = (LispSmallInteger)arg1; int n = a.value; LispObject [] t = Jlisp.lit; switch (n) { case 0: return t[Lit.space]; case 1: return t[Lit.newline]; case 2: return t[Lit.backspace]; case 3: return t[Lit.tab]; // case 4: vertical tab case 5: return t[Lit.formFeed]; case 6: return t[Lit.cr]; case 7: return t[Lit.rubout]; case 8: return t[Lit.eof]; // case 9: attention (^G ??) case 10: return t[Lit.escape]; default: return Jlisp.nil; } } } class Special_form_pFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return (arg1 instanceof Symbol && ((Symbol)arg1).special != null) ? Jlisp.lispTrue : Jlisp.nil; } } class SpoolFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Start_moduleFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return Fasl.startModule(arg1); } } // (stop) exist from this Lisp. class StopFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { Jlisp.println(); Jlisp.backtrace = false; throw new ProgEvent(ProgEvent.STOP, arg1, "STOP function called"); } } class StreampFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { return arg1 instanceof LispStream ? Jlisp.lispTrue : Jlisp.nil; } } class StringpFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { return arg1 instanceof LispString ? Jlisp.lispTrue : Jlisp.nil; } } class Stub1Fn extends BuiltinFunction { public LispObject op1(LispObject arg1) { return Jlisp.nil; } } class Stub2Fn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) { return Jlisp.nil; } } class SublaFn extends BuiltinFunction { public LispObject op2(LispObject u, LispObject v) throws Exception { if (u == Jlisp.nil || v == Jlisp.nil) return v; else if (v.atom) { while (!u.atom) { LispObject cu = u; u = cu.cdr; if (cu.car.atom) continue; LispObject ccu = cu.car; if (v instanceof LispNumber) // @@@ { if (v.lispequals(ccu.car)) return ccu.car; // @@@ } // @@@ else if (ccu.car == v) return ccu.cdr; } return v; } LispObject cv = v; LispObject y = new Cons( op2(u, cv.car), op2(u, cv.cdr)); if (y.lispequals(v)) return v; else return y; } } class SublisFn extends BuiltinFunction { public LispObject op2(LispObject al, LispObject x) throws Exception { LispObject a = al; while (!a.atom) { LispObject c = a; a = c.cdr; if (c.car.atom) continue; LispObject cc = c.car; if (cc.car.lispequals(x)) return cc.cdr; } if (x.atom) return x; LispObject cx = x; LispObject aa = op2(al, cx.car); LispObject bb = op2(al, cx.cdr); if (aa == cx.car && bb == cx.cdr) return x; else return new Cons(aa, bb); } } class SubstFn extends BuiltinFunction { public LispObject opn(LispObject [] args) throws Exception { if (args.length != 3) return error("subst called with " + args.length + "args when 1 to 3 expected"); return subst(args[0], args[1], args[2]); } LispObject subst(LispObject a, LispObject b, LispObject c) { if (b.lispequals(c)) return a; if (c.atom) return c; LispObject cc = c; LispObject aa = subst(a, b, cc.car); LispObject bb = subst(a, b, cc.cdr); if (aa == cc.car && bb == cc.cdr) return c; else return new Cons(aa, bb); } } class SxhashFn extends BuiltinFunction { // use md60 here... public LispObject op1(LispObject arg1) throws Exception { LispStream f = new LispDigester(); LispObject save = Jlisp.lit[Lit.std_output].car/*value*/; try { Jlisp.lit[Lit.std_output].car/*value*/ = f; arg1.print(LispObject.noLineBreak+LispObject.printEscape); } finally { Jlisp.lit[Lit.std_output].car/*value*/ = save; } byte [] res = f.md.digest(); return LispInteger.valueOf(new BigInteger(res).shiftRight(68)); } } class Symbol_argcountFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Symbol_envFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { if (!(arg1 instanceof Symbol)) return Jlisp.nil; LispFunction f = ((Symbol)arg1).fn; if (f instanceof FnWithEnv) return new LispVector(((FnWithEnv)f).env); else return Jlisp.nil; } } class Symbol_fastgetsFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Symbol_fn_cellFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { LispFunction f = ((Symbol)arg1).fn; if (f instanceof Undefined) return Jlisp.nil; else return f; } } class Symbol_functionFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return ((Symbol)arg1).fn; } } class Symbol_make_fastgetFn extends BuiltinFunction { public LispObject op1(LispObject arg1) { return Jlisp.nil; } public LispObject op2(LispObject arg1, LispObject arg2) { return Jlisp.nil; } } class Symbol_nameFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return new LispString(((Symbol)arg1).pname); } } class Symbol_protectFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } class Symbol_set_definitionFn extends BuiltinFunction { public LispObject op2(LispObject arg1, LispObject arg2) throws Exception { Symbol a1 = (Symbol)arg1; if (!arg2.atom) { LispObject a2 = arg2; if (a2.car == Jlisp.lit[Lit.lambda]) { a1.fn = new Interpreted(a2.cdr); return arg1; } else if (a2.car instanceof LispInteger) { int nargs = a2.car.intValue(); int nopts = nargs >> 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() { 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 op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } 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) { 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) 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) { 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) { int n = ((LispSmallInteger)arg1).value; LispStream f = (LispStream)Jlisp.lit[Lit.std_output].car/*value*/; for (int i=0; i<n; i++) f.print(" "); return Jlisp.nil; } } class TyiFn extends BuiltinFunction { public LispObject op1(LispObject arg1) throws Exception { return error(name + " not yet implemented"); } } } // end of Fns3.java