Index: gnu/expr/Language.java =================================================================== --- gnu/expr/Language.java (revision 7247) +++ gnu/expr/Language.java (working copy) @@ -308,6 +308,19 @@ { return Environment.make("environment-"+(++envCounter), environ); } + + /** + * Get the corresponding {@link Type} for a given name. + * + * If a subclass does not require any modification to the types found + * in {@code LispLanguage}, then they should just call + * {@link LispLanguage#getNamedLispType(java.lang.String)} + * + * @param name The name of a type to search for. + * @return The corresponding {@link Type} if a suitable one can be found, + * otherwise {@code null}. + */ + abstract public Type getNamedType (String name); public Environment getLangEnvironment() { return environ; } Index: gnu/commonlisp/lang/CommonLisp.java =================================================================== --- gnu/commonlisp/lang/CommonLisp.java (revision 7247) +++ gnu/commonlisp/lang/CommonLisp.java (working copy) @@ -2,15 +2,19 @@ // This is free software; for terms and warranty disclaimer see ./COPYING. package gnu.commonlisp.lang; -import gnu.mapping.*; -import gnu.lists.*; -import gnu.expr.*; -import gnu.text.Char; -import kawa.standard.Scheme; import gnu.bytecode.Type; -import gnu.kawa.lispexpr.LangPrimType; +import gnu.expr.Language; import gnu.kawa.functions.DisplayFormat; import gnu.kawa.functions.NumberCompare; +import gnu.kawa.lispexpr.LangPrimType; +import gnu.kawa.lispexpr.LispLanguage; +import gnu.lists.AbstractFormat; +import gnu.mapping.Environment; +import gnu.mapping.LocationEnumeration; +import gnu.mapping.Procedure; +import gnu.text.Char; +import java.util.HashMap; +import kawa.standard.Scheme; public class CommonLisp extends Lisp2 { @@ -111,7 +115,7 @@ loadClass("kawa.lib.std_syntax"); loadClass("kawa.lib.lists"); loadClass("kawa.lib.strings"); - loadClass("gnu.commonlisp.lisp.PrimOps"); + loadClass("gnu.commonlisp.lisp.primitives"); } catch (java.lang.ClassNotFoundException ex) { @@ -125,7 +129,6 @@ lambda.defaultDefault = nilExpr; defun("lambda", lambda); defun("defun", new defun(lambda)); - defun("defvar", new defvar(false)); defun("defconst", new defvar(true)); defun("defsubst", new defun(lambda)); @@ -149,8 +152,10 @@ defProcStFld(">", "gnu.commonlisp.lang.CommonLisp", "numGrt"); defProcStFld("<=", "gnu.commonlisp.lang.CommonLisp", "numLEq"); defProcStFld(">=", "gnu.commonlisp.lang.CommonLisp", "numGEq"); - defProcStFld("functionp", "gnu.commonlisp.lisp.PrimOps"); + defProcStFld("the", "gnu.kawa.functions.Convert", "as"); + + defSntxStFld("%flet", "gnu.commonlisp.lang.flet", "flet"); } public static CommonLisp getInstance() @@ -167,33 +172,60 @@ static final AbstractFormat writeFormat = new DisplayFormat(true, 'C'); static final AbstractFormat displayFormat = new DisplayFormat(false, 'C'); + @Override public AbstractFormat getFormat(boolean readable) { return readable ? writeFormat : displayFormat; } LangPrimType booleanType; + private HashMap types; + private HashMap typeToStringMap; + + public synchronized HashMap getTypeMap () + { + if (types == null) + { + types = new HashMap(); + booleanType = new LangPrimType(Type.booleanType, CommonLisp.getInstance()); + types.put("boolean", booleanType); + types.put("t", Type.objectType); + types.put("nil", Type.voidType); + } + + return types; + } + @Override + // FIXME: refactor public Type getTypeFor(String name) { if (name == "t") name = "java.lang.Object"; return Scheme.string2Type(name); } - - public Type getTypeFor (Class clas) + + @Override + public Type getNamedType (String name) { - if (clas.isPrimitive()) - { - String name = clas.getName(); - if (name.equals("boolean")) - { - if (booleanType == null) - booleanType = new LangPrimType(Type.booleanType, this); - return booleanType; - } - return Scheme.getNamedType(name); - } - return Type.make(clas); + Type type; + + type = getTypeMap().get(name); + + if (type == null) { + return LispLanguage.getNamedLispType(name); + } + + return type; } + + @Override + public Type getTypeFor (Class clas) { + Type type = super.getTypeFor(clas); + if (type == null) { + type = getTypeMap().get(clas.getName()); + } + return type; + } + } Index: gnu/commonlisp/lang/Lisp2Compilation.java =================================================================== --- gnu/commonlisp/lang/Lisp2Compilation.java (revision 7247) +++ gnu/commonlisp/lang/Lisp2Compilation.java (working copy) @@ -1,8 +1,13 @@ package gnu.commonlisp.lang; -import kawa.lang.*; -import gnu.bytecode.*; + +import gnu.bytecode.ClassType; +import gnu.bytecode.CodeAttr; import gnu.expr.*; -import gnu.text.*; +import gnu.lists.LList; +import gnu.lists.Pair; +import gnu.lists.SeqPosition; +import gnu.text.SourceMessages; +import kawa.lang.Translator; public class Lisp2Compilation extends Translator { @@ -11,7 +16,8 @@ super(language, messages, lexical); } - public void emitPushBoolean(boolean value) + @Override + public void emitPushBoolean (boolean value) { CodeAttr code = getCode(); if (value) @@ -20,4 +26,136 @@ code.emitGetStatic(Compilation.scmListType.getDeclaredField("Empty")); } + /** + * Re-write a Scheme in S-expression format into internal form. + */ + @Override + public Expression rewrite_body (Object exp) + { + // NOTE we have both a rewrite_body and a rewriteBody. + // This is confusing, at the least. FIXME. + Object saved = pushPositionOf(exp); + LetExp defs = new LetExp(); + int first = formStack.size(); + defs.outer = current_scope; + current_scope = defs; + try + { + LList list = scanBody(exp, defs, true); + if (list.isEmpty()) + formStack.add(syntaxError("body with no expressions")); + int ndecls = 0; + for (Declaration decl = defs.firstDecl(); decl != null; decl = decl.nextDecl()) + { + if (!decl.getFlag(Declaration.IS_DYNAMIC)) + { + ndecls++; + decl.setInitValue(QuoteExp.undefined_exp); + } + } + + Expression body; + body = processDeclare(list); + + if (body == null) + { + rewriteBody(list); + body = makeBody(first, null); + } + + setLineOf(body); + if (ndecls == 0) + return body; + defs.setBody(body); + setLineOf(defs); + return defs; + } finally + { + pop(defs); + popPositionOf(saved); + } + } + + /** + * Process the DECLARE (if any) in a Common Lisp form. + * + * @param list The body of this expression. + * @return the {@code LetExp} representing the new scope of these declared + * variables, or null if no declarations were found. + */ + private Expression processDeclare (LList list) + { + LetExp letexp = null; + // Could be checked futher up the call chain. + if (list.isEmpty()) + return null; + // Declarations are always at the start of a body. + Object head = ((Pair) list).getCar(); + // The body to rewrite into the new LET body, this is just what follows + // the DECLARE form in list + Object body = ((Pair) list).getCdr(); + // For cases like (declare (integer x1 x2 .. xn)), maintain a stack of the + // xi which are then popped back off for their types to be set. This is + // to avoid creating a new lexical scope for each xi since we want to + // call letVariable() on each of the xi before letEnter(). + //Stack declarations = new Stack(); + + if (head instanceof Pair && matches(((Pair) head).getCar(), "declare")) + { + SeqPosition declIterator = ((LList) head).getIterator(1); + SeqPosition varIterator; + Pair declItem; + Object var; + Declaration varDecl, aliasedDecl; + ReferenceExp ref; + // Create a new lexical environment for this DECLARE + letStart(); + + // eg. declIterator == [(integer x y) (float z) (gnu.lists.Sequence k)] + while (declIterator.hasNext()) + { + declItem = (Pair) declIterator.next(); + if (matches(declItem.getCar(), "type")) + { + // Just skip past TYPE and process the type declarations + varIterator = ((LList) declItem.getCdr()).getIterator(1); + } + // .. other checks could be performed here + else + { + // By default we process type declarations + varIterator = ((LList) declItem.getCdr()).getIterator(); + } + + if (!varIterator.hasNext()) + { + // FIXME: Add better diagnostics... + return syntaxError("bad declare syntax"); + } + + // e.g varIterator = (x y) or (z) or (k) + // For each aliased variable, place it in the new lexical environment + while (varIterator.hasNext()) + { + var = varIterator.next(); + varDecl = lexical.get(var); + if (varDecl != null) + { + aliasedDecl = new Declaration(varDecl.getSymbol()); + ref = new ReferenceExp(varDecl); + letVariable(aliasedDecl, ref); + aliasedDecl.setType(this.exp2Type((Pair) declItem)); //FIXME (type ...) + aliasedDecl.setFlag(Declaration.TYPE_SPECIFIED); + } + else + { + error('w', "No declaration seen for `" + var + "`"); + } + } + } + letEnter(); + letexp = letDone(rewrite_body(body)); + } + return letexp; + } } Index: gnu/commonlisp/lang/Lisp2.java =================================================================== --- gnu/commonlisp/lang/Lisp2.java (revision 7247) +++ gnu/commonlisp/lang/Lisp2.java (working copy) @@ -2,14 +2,15 @@ // This is free software; for terms and warranty disclaimer see ./COPYING. package gnu.commonlisp.lang; +import gnu.bytecode.Type; import gnu.expr.*; -import gnu.lists.*; +import gnu.kawa.lispexpr.LangObjType; +import gnu.kawa.lispexpr.LispLanguage; +import gnu.kawa.lispexpr.ReadTable; +import gnu.kawa.reflect.FieldLocation; +import gnu.lists.FString; +import gnu.lists.LList; import gnu.mapping.*; -import gnu.bytecode.CodeAttr; -import gnu.bytecode.ClassType; -import gnu.text.*; -import gnu.kawa.lispexpr.*; -import gnu.kawa.reflect.FieldLocation; /** Abstract class for Lisp-like languages with separate namespaces. */ @@ -20,31 +21,37 @@ public static final Symbol TRUE = Namespace.getDefault().getSymbol("t"); public static final Expression nilExpr = new QuoteExp(FALSE); + @Override public boolean isTrue(Object value) { return value != FALSE; } + @Override public Object booleanObject(boolean b) { if (b) return TRUE; else return FALSE; } + @Override public Object noValue() { return FALSE; } + @Override public boolean hasSeparateFunctionNamespace() { return true; } + @Override public boolean selfEvaluatingSymbol (Object obj) { return obj instanceof Keyword || obj == TRUE || obj == FALSE; } + @Override public Object getEnvPropertyFor (java.lang.reflect.Field fld, Object value) { if (Compilation.typeProcedure.getReflectClass() @@ -154,6 +161,12 @@ tab.setInitialColonIsKeyword(true); return tab; } + + @Override + public Type getNamedType (String name) + { + return LispLanguage.getNamedLispType(name); + } public String getCompilationClass () { return "gnu.commonlisp.lang.Lisp2Compilation"; } } Index: gnu/commonlisp/lang/Makefile.am =================================================================== --- gnu/commonlisp/lang/Makefile.am (revision 7247) +++ gnu/commonlisp/lang/Makefile.am (working copy) @@ -7,6 +7,7 @@ Lisp2Compilation.java \ defvar.java \ defun.java \ + flet.java \ function.java \ prog1.java \ setq.java \ Index: gnu/commonlisp/lang/flet.java =================================================================== --- gnu/commonlisp/lang/flet.java (revision 0) +++ gnu/commonlisp/lang/flet.java (revision 0) @@ -0,0 +1,19 @@ +package gnu.commonlisp.lang; + +import gnu.expr.Declaration; +import kawa.standard.let; + +/** + * + * @author chturne + */ +public class flet extends let +{ + public static final flet flet = new flet(); + + public flet () + { + this.setName("flet"); + this.settingProcedures = true; + } +} Index: gnu/commonlisp/lisp/Makefile.am =================================================================== --- gnu/commonlisp/lisp/Makefile.am (revision 7247) +++ gnu/commonlisp/lisp/Makefile.am (working copy) @@ -2,15 +2,14 @@ include $(top_srcdir)/Make-rules -#java_CLISP = lists.lisp -java_SCM = PrimOps.scm +java_CLISP = primitives.lisp PACKAGE_FNAME = gnu-commonlisp-lisp -EXTRA_DIST = $(java_SCM) +EXTRA_DIST = $(java_CLISP) EXTRA_GCJ_INPUTS = *.class -all: Makefile ../../../kawa/java-classes.stamp scm-classes.stamp $(@GCJ_COMPILED_SELECTED@) +all: Makefile ../../../kawa/java-classes.stamp clisp-classes.stamp $(@GCJ_COMPILED_SELECTED@) ../../../kawa/java-classes.stamp: cd ../../../kawa; $(MAKE) Index: gnu/commonlisp/lisp/primitives.lisp =================================================================== --- gnu/commonlisp/lisp/primitives.lisp (revision 0) +++ gnu/commonlisp/lisp/primitives.lisp (revision 0) @@ -0,0 +1,170 @@ +(defun car (x) + (if (null x) + nil + (invoke (the pair x) 'getCar))) + +(defun cdr (x) + (if (null x) + nil + (invoke (the pair x) 'getCdr))) + +(defun setcar (p x) + (declare (pair p)) + (set-car! p x)) + +(defun setcdr (p x) + (declare (pair p)) + (set-cdr! p x)) + +(defun boundp (symbol) :: |clisp:boolean| + ((primitive-static-method "isBound" + ()) + symbol)) + +(defun symbolp (x) :: |clisp:boolean| + (invoke-static 'isSymbol x)) + +(defun symbol-name (symbol) + (invoke-static 'getPrintName symbol)) + +(defun symbol-plist (symbol) + (invoke-static + 'getPropertyList symbol)) + +(defun setplist (symbol plist) + (invoke-static + 'setPropertyList + symbol plist) + plist) + +(defun plist-get (plist prop &optional default) + (invoke-static + 'plistGet + plist prop default)) + +(defun plist-put (plist prop value) + (invoke-static + 'plistPut + plist prop value)) + +(defun plist-remprop (plist prop) + (invoke-static + 'plistRemove + plist prop)) + +(defun plist-member (plist prop) + (if (null + (invoke-static + 'plistGet + plist prop nil)) + nil + t)) + +(defun get (symbol property &optional default) + (declare (gnu.mapping.Symbol symbol)) + (invoke-static + 'getProperty + symbol property default)) + +(defun put (symbol property value) + (invoke-static + 'putProperty + symbol property value)) + +(defun symbol-value (sym) + (invoke (invoke-static 'getCurrent) + 'get + (invoke-static + 'getSymbol sym))) + +(defun set (symbol value) + (invoke (invoke-static 'getCurrent) + 'put + (invoke-static 'getSymbol symbol) + value)) + +(defun symbol-function (symbol) + (invoke-static + 'getFunctionBinding symbol)) + +(defun fset (symbol object) + (invoke-static + 'setFunctionBinding + (invoke-static + 'getCurrent) + symbol object)) + +(defun apply (func &rest (args :: )) + (invoke (the + (if (symbolp func) (symbol-function func) func)) + 'applyN + (invoke-static + 'getArguments + args + 0 #'apply))) + +(defun funcall (func &rest args) + (apply func args)) + +(define-syntax flet + (syntax-rules () + ((_ ((fname parameters body ...) ...) + e ...) + (%flet ((fname (lambda parameters body ...)) ...) + e ...)))) + +;; ARRAYS + +(defun length (x) + (declare (gnu.lists.Sequence x)) + (invoke x 'size)) + +(defun arrayp (x) :: |clisp:boolean| + (instance? x )) + +(defun aref (array k) + (declare (gnu.lists.Sequence array) + (int k)) + (invoke array 'get k)) + +(defun aset (array k obj) + (declare (gnu.lists.Sequence array) + (int k)) + (invoke array 'set k obj) + obj) + +(defun fillarray (array obj) + (declare (gnu.lists.SimpleVector array)) + (invoke array 'fill obj)) + +;; STRINGS + +(defun stringp (x) :: |clisp:boolean| + (instance? x )) + +(defun make-string (count ch) + (declare ( count)) + (make count + (invoke-static + 'asChar ch))) + +(defun substring (str from &optional (to nil)) + (declare (string str)) + (cond ((eq to nil) + (set! to (string-length str))) + ((< to 0) + (set! to (- (string-length str) to))) + ((< from 0) + (set! from (- (string-length str) from)))) + (make str + (the from) + (the (- to from)))) + +(defun char-to-string (ch) + (make + 1 + (invoke-static + 'asChar ch))) + +(defun functionp (x) :: |clisp:boolean| + (instance? x )) Index: gnu/commonlisp/testsuite/lang-test.lisp =================================================================== --- gnu/commonlisp/testsuite/lang-test.lisp (revision 7247) +++ gnu/commonlisp/testsuite/lang-test.lisp (working copy) @@ -1,4 +1,4 @@ -(test-init "Common Lisp tests" 11) +(test-init "Common Lisp tests" 18) (setq y 100) (defun foo1 (x) @@ -30,3 +30,21 @@ (test t 'functionp-2 (functionp #'list)) (test t 'functionp-3 (functionp (function list))) (test '(3 4) 'function-1 ((function list) 3 4)) + +(test 6 'funcall-1 (funcall #'+ 1 2 3)) +(test 1 'funcall-2 (funcall 'car '(1 2 3))) + +(test 6 'flet-1 (flet ((flet1 (n) (+ n n))) + (flet ((flet1 (n) (+ 2 (flet1 n)))) + (flet1 2)))) + +(defun dummy-function () 'top-level) +(test 'top-level 'funcall-3 (funcall #'dummy-function)) + +(test 'shadow 'flet-2 (flet ((dummy-function () 'shadow)) + (funcall #'dummy-function))) + +(test t 'flet-3 (eq (funcall #'dummy-function) (funcall 'dummy-function))) +(test '() 'flet-4 (flet ((dummy-function () 'shadow)) + (eq (funcall #'dummy-function) + (funcall 'dummy-function)))) Index: gnu/kawa/lispexpr/LispLanguage.java =================================================================== --- gnu/kawa/lispexpr/LispLanguage.java (revision 7247) +++ gnu/kawa/lispexpr/LispLanguage.java (working copy) @@ -7,9 +7,12 @@ import gnu.text.*; import gnu.lists.*; import gnu.bytecode.Access; +import gnu.bytecode.ClassType; import gnu.bytecode.Field; +import gnu.bytecode.Type; import gnu.mapping.EnvironmentKey; import gnu.kawa.reflect.StaticFieldLocation; +import java.util.HashMap; import kawa.lang.Translator; // FIXME import kawa.lang.Syntax; // FIXME @@ -40,6 +43,12 @@ /** Create a fresh ReadTable appropriate for this language. */ public abstract ReadTable createReadTable (); + + /** + * The global namespace for "quantities" in Kawa. + */ + public static final Namespace unitNamespace = + Namespace.valueOf("http://kawa.gnu.org/unit", "unit"); public LispReader getLexer(InPort inp, SourceMessages messages) { @@ -54,7 +63,6 @@ kawa.lang.Translator tr = (kawa.lang.Translator) comp; Lexer lexer = tr.lexer; ModuleExp mexp = tr.mainLambda; - Values forms = new Values(); LispReader reader = (LispReader) lexer; Compilation saveComp = Compilation.setSaveCurrent(tr); try @@ -121,6 +129,127 @@ tr.resolveModule(tr.getModule()); } + static HashMap types; + static HashMap typeToStringMap; + + public static synchronized HashMap getLispTypeMap () { + if (types == null) + { + types = new HashMap (); + types.put ("void", LangPrimType.voidType); + types.put ("int", LangPrimType.intType); + types.put ("char", LangPrimType.charType); + types.put ("byte", LangPrimType.byteType); + types.put ("short", LangPrimType.shortType); + types.put ("long", LangPrimType.longType); + types.put ("float", LangPrimType.floatType); + types.put ("double", LangPrimType.doubleType); + types.put ("never-returns", Type.neverReturnsType); + + types.put ("Object", Type.objectType); + types.put ("String", Type.toStringType); + + types.put ("object", Type.objectType); + types.put ("number", LangObjType.numericType); + types.put ("quantity", ClassType.make("gnu.math.Quantity")); + types.put ("complex", ClassType.make("gnu.math.Complex")); + types.put ("real", LangObjType.realType); + types.put ("rational", LangObjType.rationalType); + types.put ("integer", LangObjType.integerType); + types.put ("symbol", ClassType.make("gnu.mapping.Symbol")); + types.put ("namespace", ClassType.make("gnu.mapping.Namespace")); + types.put ("keyword", ClassType.make("gnu.expr.Keyword")); + types.put ("pair", ClassType.make("gnu.lists.Pair")); + types.put ("pair-with-position", + ClassType.make("gnu.lists.PairWithPosition")); + types.put ("constant-string", ClassType.make("java.lang.String")); + types.put ("abstract-string", ClassType.make("gnu.lists.CharSeq")); + types.put ("character", ClassType.make("gnu.text.Char")); + types.put ("vector", LangObjType.vectorType); + types.put ("string", LangObjType.stringType); + types.put ("empty-list", ClassType.make("gnu.lists.EmptyList")); + types.put ("list", LangObjType.listType); + types.put ("function", ClassType.make("gnu.mapping.Procedure")); + types.put ("procedure", LangObjType.procedureType); + types.put ("input-port", ClassType.make("gnu.mapping.InPort")); + types.put ("output-port", ClassType.make("gnu.mapping.OutPort")); + types.put ("string-output-port", + ClassType.make("gnu.mapping.CharArrayOutPort")); + types.put ("string-input-port", + ClassType.make("gnu.mapping.CharArrayInPort")); + types.put ("record", ClassType.make("kawa.lang.Record")); + types.put ("type", LangObjType.typeType); + types.put ("class-type", LangObjType.typeClassType); + types.put ("class", LangObjType.typeClass); + types.put ("promise", LangObjType.promiseType); + types.put ("document", ClassType.make("gnu.kawa.xml.KDocument")); + types.put ("readtable", ClassType.make("gnu.kawa.lispexpr.ReadTable")); + } + return types; + } + + public static Type getNamedLispType (String name) + { + getLispTypeMap(); + Type type = (Type) types.get(name); + + int colon = name.indexOf(':'); + + if (type == null && colon > 0) + { + + String lang = name.substring(0, colon); + Language interp = Language.getInstance(lang); + if (interp == null) + throw new RuntimeException("unknown type '" + name + + "' - unknown language '" + + lang + '\''); + + type = interp.getNamedType(name.substring(colon + 1)); + + if (type != null) + types.put(name, type); + } + + return type; + } + + public Type getTypeFor (Class clas) + { + String name = clas.getName(); + if (clas.isPrimitive()) + return getNamedLispType(name); + if ("java.lang.String".equals(name)) + return Type.toStringType; + if ("gnu.math.IntNum".equals(name)) + return LangObjType.integerType; + if ("gnu.math.DFloNum".equals(name)) + return LangObjType.dflonumType; + if ("gnu.math.RatNum".equals(name)) + return LangObjType.rationalType; + if ("gnu.math.RealNum".equals(name)) + return LangObjType.realType; + if ("gnu.math.Numeric".equals(name)) + return LangObjType.numericType; + if ("gnu.lists.FVector".equals(name)) + return LangObjType.vectorType; + if ("gnu.lists.LList".equals(name)) + return LangObjType.listType; + if ("gnu.text.Path".equals(name)) + return LangObjType.pathType; + if ("gnu.text.URIPath".equals(name)) + return LangObjType.URIType; + if ("gnu.text.FilePath".equals(name)) + return LangObjType.filepathType; + if ("java.lang.Class".equals(name)) + return LangObjType.typeClass; + if ("gnu.bytecode.Type".equals(name)) + return LangObjType.typeType; + if ("gnu.bytecode.ClassType".equals(name)) + return LangObjType.typeClassType; + return Type.make(clas); + } + public Declaration declFromField (ModuleExp mod, Object fvalue, Field fld) { Declaration fdecl = super.declFromField(mod, fvalue, fld); Index: gnu/xquery/lang/XQuery.java =================================================================== --- gnu/xquery/lang/XQuery.java (revision 7247) +++ gnu/xquery/lang/XQuery.java (working copy) @@ -8,14 +8,13 @@ import gnu.text.Char; import kawa.standard.Scheme; import gnu.bytecode.*; -import gnu.kawa.lispexpr.LangPrimType; -import gnu.xquery.util.*; import gnu.xml.*; import gnu.text.Lexer; import gnu.text.SourceMessages; import java.io.Reader; import java.util.Vector; import gnu.kawa.functions.ConstantFunction0; +import gnu.kawa.lispexpr.LispLanguage; import gnu.kawa.reflect.ClassMethods; import gnu.math.IntNum; import gnu.kawa.xml.*; @@ -869,7 +868,7 @@ String name = clas.getName(); if (name.equals("boolean")) return XDataType.booleanType; - return Scheme.getNamedType(name); + return LispLanguage.getNamedLispType(name); } else if (! clas.isArray()) { @@ -1028,6 +1027,12 @@ } return value; } + + @Override + public Type getNamedType (String name) + { + return getTypeFor(name); + } } class Prompter extends Procedure1 Index: gnu/jemacs/lang/ELisp.java =================================================================== --- gnu/jemacs/lang/ELisp.java (revision 7247) +++ gnu/jemacs/lang/ELisp.java (working copy) @@ -210,7 +210,7 @@ booleanType = new LangPrimType(Type.booleanType, this); return booleanType; } - return Scheme.getNamedType(name); + return LispLanguage.getNamedLispType(name); } return Type.make(clas); } Index: kawa/lang/Translator.java =================================================================== --- kawa/lang/Translator.java (revision 7247) +++ kawa/lang/Translator.java (working copy) @@ -13,9 +13,16 @@ import java.util.*; import gnu.kawa.functions.GetNamedPart; import gnu.kawa.functions.CompileNamedPart; +import gnu.kawa.functions.MultiplyOp; +import gnu.kawa.xml.XmlNamespace; +import gnu.math.DFloNum; +import gnu.math.IntNum; +import gnu.math.Unit; import gnu.text.SourceLocator; /* #ifdef enable:XML */ import gnu.xml.NamespaceBinding; +import kawa.standard.Scheme; +import kawa.standard.expt; /* #endif */ /** Used to translate from source to Expression. @@ -812,7 +819,6 @@ if (decl.getContext() instanceof PatternScope) return syntaxError("reference to pattern variable "+decl.getName()+" outside syntax template"); } - ReferenceExp rexp = new ReferenceExp (nameToLookup, decl); rexp.setContextDecl(cdecl); rexp.setLine(this); @@ -833,11 +839,262 @@ } /** If a symbol is lexically unbound, look for a default binding. - * The default implementation does nothing. * @return null if no binidng, or an Expression. */ - public Expression checkDefaultBinding (Symbol name, Translator tr) + // FIXME: This method needs refactoring. The quantities method should be moved + // to its own method, at least! + public Expression checkDefaultBinding (Symbol symbol, Translator tr) { + Namespace namespace = symbol.getNamespace(); + String local = symbol.getLocalPart(); + + if (namespace instanceof XmlNamespace) + return makeQuoteExp(((XmlNamespace) namespace).get(local)); + + if (namespace.getName() == LispLanguage.unitNamespace.getName()) + { + Object val = Unit.lookup(local); + if (val != null) + return makeQuoteExp(val); + } + + String name = symbol.toString(); + int len = name.length(); + + char ch0 = name.charAt(0); + + if (ch0 == '@') + { + String rest = name.substring(1); + Expression classRef = tr.rewrite(Symbol.valueOf(rest)); + return MakeAnnotation.makeAnnotationMaker(classRef); + } + + // Look for quantities. + if (ch0 == '-' || ch0 == '+' || Character.digit(ch0, 10) >= 0) + { + // 1: initial + or -1 seen. + // 2: digits seen + // 3: '.' seen + // 4: fraction seen + // 5: [eE][=+]?[0-9]+ seen + int state = 0; + int i = 0; + for (; i < len; i++) + { + char ch = name.charAt(i); + if (Character.digit(ch, 10) >= 0) + state = state < 3 ? 2 : state < 5 ? 4 : 5; + else if ((ch == '+' || ch == '-') && state == 0) + state = 1; + else if (ch == '.' && state < 3) + state = 3; + else if ((ch == 'e' || ch == 'E') && (state == 2 || state == 4) + && i + 1 < len) + { + int j = i+1; + char next = name.charAt(j); + if ((next == '-' || next == '+') && ++j < len) + next = name.charAt(j); + if (Character.digit(next, 10) < 0) + break; + state = 5; + i = j+1; +} + else + break; + } + tryQuantity: + if (i < len && state > 1) + { + DFloNum num = new DFloNum(name.substring(0,i)); + boolean div = false; + Vector vec = new Vector(); + for (; i < len ;) + { + char ch = name.charAt(i++); + if (ch == '*') + { + if (i == len) break tryQuantity; + ch = name.charAt(i++); + } + else if (ch == '/') + { + if (i == len || div) break tryQuantity; + div = true; + ch = name.charAt(i++); + } + int unitStart = i-1; + int unitEnd; + for (;;) + { + if (! Character.isLetter(ch)) + { + unitEnd = i - 1; + if (unitEnd == unitStart) + break tryQuantity; + break; + } + if (i == len) + { + unitEnd = i; + ch = '1'; + break; + } + ch = name.charAt(i++); + } + vec.addElement(name.substring(unitStart, unitEnd)); + boolean expRequired = false; + if (ch == '^') + { + expRequired = true; + if (i == len) break tryQuantity; + ch = name.charAt(i++); + } + boolean neg = div; + if (ch == '+') + { + expRequired = true; + if (i == len) break tryQuantity; + ch = name.charAt(i++); + } + else if (ch == '-') + { + expRequired = true; + if (i == len) break tryQuantity; + ch = name.charAt(i++); + neg = ! neg; + } + int nexp = 0; + int exp = 0; + for (;;) + { + int dig = Character.digit(ch, 10); + if (dig <= 0) + { + i--; + break; + } + exp = 10 * exp + dig; + nexp++; + if (i == len) + break; + ch = name.charAt(i++); + } + if (nexp == 0) + { + exp = 1; + if (expRequired) + break tryQuantity; + } + if (neg) + exp = - exp; + vec.addElement(IntNum.make(exp)); + } + if (i == len) + { + int nunits = vec.size() >> 1; + Expression[] units = new Expression[nunits]; + for (i = 0; i < nunits; i++) + { + String uname = (String) vec.elementAt(2*i); + Symbol usym = LispLanguage.unitNamespace.getSymbol(uname.intern()); + Expression uref = tr.rewrite(usym); + IntNum uexp = (IntNum) vec.elementAt(2*i+1); + if (uexp.longValue() != 1) + uref = new ApplyExp(expt.expt, + new Expression[] { uref , makeQuoteExp(uexp) }); + units[i] = uref; + } + Expression unit; + if (nunits == 1) + unit = units[0]; + else + unit = new ApplyExp(MultiplyOp.$St, units); + return new ApplyExp(MultiplyOp.$St, + new Expression[] { makeQuoteExp(num), + unit }); + } + } + } + + boolean sawAngle; + if (len > 2 && ch0 == '<' && name.charAt(len-1) == '>') + { + name = name.substring(1, len-1); + len -= 2; + sawAngle = true; + } + else + sawAngle = false; + int rank = 0; + while (len > 2 && name.charAt(len-2) == '[' && name.charAt(len-1) == ']') + { + len -= 2; + rank++; + } + + String cname = name; + if (rank != 0) + cname = name.substring(0, len); + try + { + Class clas; + Type type = Language.getDefaultLanguage().getNamedType(cname); + if (rank > 0 && (! sawAngle || type == null)) + { + Symbol tsymbol = namespace.getSymbol(cname.intern()); + Expression texp = tr.rewrite(tsymbol, false); + texp = InlineCalls.inlineCalls(texp, tr); + if (! (texp instanceof ErrorExp)) + type = tr.getLanguage().getTypeFor(texp); + } + if (type != null) + { + // Somewhat inconsistent: Types named by getNamedType are Type, + // while standard type/classes are Class. FIXME. + while (--rank >= 0) + type = gnu.bytecode.ArrayType.make(type); + return makeQuoteExp(type); + } + else + { + type = Type.lookupType(cname); + if (type instanceof gnu.bytecode.PrimType) + clas = type.getReflectClass(); + else + { + if (cname.indexOf('.') < 0) + cname = (tr.classPrefix + + Compilation.mangleNameIfNeeded(cname)); + clas = ClassType.getContextClass(cname); + } + } + if (clas != null) + { + if (rank > 0) + { + type = Type.make(clas); + while (--rank >= 0) + type = gnu.bytecode.ArrayType.make(type); + clas = type.getReflectClass(); + } + return makeQuoteExp(clas); + } + } + catch (ClassNotFoundException ex) + { + Package pack = gnu.bytecode.ArrayClassLoader.getContextPackage(name); + if (pack != null) + return makeQuoteExp(pack); + } + catch (NoClassDefFoundError ex) + { + tr.error('w', "error loading class "+cname+" - "+ex.getMessage()+" not found"); + } + catch (Throwable ex) + { + } return null; } @@ -1259,7 +1516,7 @@ } } - private void rewriteBody (LList forms) + protected void rewriteBody (LList forms) { while (forms != LList.Empty) { @@ -1278,7 +1535,7 @@ } /** Combine a list of zero or more expression forms into a "body". */ - private Expression makeBody(int first, ScopeExp scope) + protected Expression makeBody(int first, ScopeExp scope) { int nforms = formStack.size() - first; if (nforms == 0) Index: kawa/standard/let.java =================================================================== --- kawa/standard/let.java (revision 7247) +++ kawa/standard/let.java (working copy) @@ -15,19 +15,30 @@ public class let extends Syntax { public static final let let = new let(); - static { let.setName("let"); } + + /** + * Used for constructs such as FLET, where we intend to set a function binding + * rather than an ordinary binding. + */ + protected boolean settingProcedures; + + public let() { + this.setName("let"); + this.settingProcedures = false; + } + @Override public Expression rewrite (Object obj, Translator tr) { if (! (obj instanceof Pair)) - return tr.syntaxError ("missing let arguments"); + return tr.syntaxError ("missing " + this.getName() + " arguments"); Pair pair = (Pair) obj; Object bindings = pair.getCar(); Object body = pair.getCdr(); int decl_count = Translator.listLength(bindings); if (decl_count < 0) return tr.syntaxError("bindings not a proper list"); - + Expression[] inits = new Expression[decl_count]; Declaration[] decls = new Declaration[decl_count]; // Used to check for duplicate definitions. @@ -53,7 +64,8 @@ bind_pair_car = syntax.getDatum(); } if (! (bind_pair_car instanceof Pair)) - return tr.syntaxError ("let binding is not a pair:"+bind_pair_car); + return tr.syntaxError (this.getName() + + " binding is not a pair:"+bind_pair_car); Pair binding = (Pair) bind_pair_car; Object name = binding.getCar(); TemplateScope templateScope; @@ -67,7 +79,8 @@ templateScope = syntax == null ? null : syntax.getScope(); name = tr.namespaceResolve(name); if (! (name instanceof Symbol)) - return tr.syntaxError("variable "+name+" in let binding is not a symbol: "+obj); + return tr.syntaxError("variable "+name+" in " + this.getName() + + " binding is not a symbol: "+obj); Declaration decl = new Declaration(name); Translator.setLine(decl, binding); Symbol sym = (Symbol) name; @@ -77,6 +90,7 @@ dupenv.put(sym, templateScope, decl); decls[i] = decl; decl.setFlag(Declaration.IS_SINGLE_VALUE); + maybeSetProcedure(decl); if (templateScope != null) { Declaration alias = tr.makeRenamedAlias(decl, templateScope); @@ -93,7 +107,7 @@ binding_cdr = syntax.getDatum(); } if (! (binding_cdr instanceof Pair)) - return tr.syntaxError("let has no value for '"+name+"'"); + return tr.syntaxError(this.getName() + " has no value for '"+name+"'"); binding = (Pair) binding_cdr; binding_cdr = binding.getCdr(); Pair init; @@ -106,7 +120,7 @@ { if (! (binding_cdr instanceof Pair) || (binding = (Pair) binding_cdr).getCdr() == LList.Empty) - return tr.syntaxError("missing type after '::' in let"); + return tr.syntaxError("missing type after '::' in " + this.getName()); binding_cdr = binding.getCdr(); while (binding_cdr instanceof SyntaxForm) { @@ -125,10 +139,11 @@ init = (Pair) binding_cdr; } else - return tr.syntaxError("let binding for '"+name+"' is improper list"); + return tr.syntaxError(this.getName() + " binding for '" + this.getName() + + "' is improper list"); inits[i] = tr.rewrite_car (init, syntax); if (init.getCdr() != LList.Empty) - return tr.syntaxError("junk after declaration of "+name); + return tr.syntaxError("junk after declaration of "+this.getName()); bindings = bind_pair.getCdr(); } @@ -144,4 +159,18 @@ return let; } + + /** + * Set the procedure flag of a declaration if binding a function property. + * + * This is used for FLET .vs. LET distinction, where {@code settingProcedures} + * is true for FLET, and false for LET. + * + * @param decl The declaration to possibly set the {@code PROCEDURE} flag. + */ + protected void maybeSetProcedure (Declaration decl) + { + if (settingProcedures) + decl.setProcedureDecl(true); + } } Index: kawa/standard/Scheme.java =================================================================== --- kawa/standard/Scheme.java (revision 7247) +++ kawa/standard/Scheme.java (working copy) @@ -26,7 +26,7 @@ public static final Environment r6Environment; protected static final SimpleEnvironment kawaEnvironment; - public static LangPrimType booleanType; + private LangPrimType booleanType; public static final int FOLLOW_R5RS = 5; public static final int FOLLOW_R6RS = 6; @@ -819,7 +819,7 @@ defAliasStFld("*print-xml-indent*", "gnu.xml.XMLPrinter", "indentLoc"); defAliasStFld("html", "gnu.kawa.xml.XmlNamespace", "HTML"); - defAliasStFld("unit", "kawa.standard.Scheme", "unitNamespace"); + defAliasStFld("unit", "gnu.kawa.lispexpr.LispLanguage", "unitNamespace"); defAliasStFld("path", "gnu.kawa.lispexpr.LangObjType", "pathType"); defAliasStFld("filepath", "gnu.kawa.lispexpr.LangObjType", "filepathType"); @@ -990,135 +990,50 @@ return getInstance().getTypeFor(exp); } - static HashMap types; - static HashMap typeToStringMap; + private HashMap types; + private HashMap typeToStringMap; - static synchronized HashMap getTypeMap () + public synchronized HashMap getTypeMap () { if (types == null) + { + types = new HashMap(); + booleanType = new LangPrimType(Type.booleanType, Scheme.getInstance()); + types.put("boolean", booleanType); + for (int i = uniformVectorTags.length; --i >= 0;) { - booleanType - = new LangPrimType(Type.booleanType, Scheme.getInstance()); - types = new HashMap (); - types.put ("void", LangPrimType.voidType); - types.put ("int", LangPrimType.intType); - types.put ("char", LangPrimType.charType); - types.put ("boolean", booleanType); - types.put ("byte", LangPrimType.byteType); - types.put ("short", LangPrimType.shortType); - types.put ("long", LangPrimType.longType); - types.put ("float", LangPrimType.floatType); - types.put ("double", LangPrimType.doubleType); - types.put ("never-returns", Type.neverReturnsType); - - types.put ("Object", Type.objectType); - types.put ("String", Type.toStringType); - - types.put ("object", Type.objectType); - types.put ("number", LangObjType.numericType); - types.put ("quantity", ClassType.make("gnu.math.Quantity")); - types.put ("complex", ClassType.make("gnu.math.Complex")); - types.put ("real", LangObjType.realType); - types.put ("rational", LangObjType.rationalType); - types.put ("integer", LangObjType.integerType); - types.put ("symbol", ClassType.make("gnu.mapping.Symbol")); - types.put ("namespace", ClassType.make("gnu.mapping.Namespace")); - types.put ("keyword", ClassType.make("gnu.expr.Keyword")); - types.put ("pair", ClassType.make("gnu.lists.Pair")); - types.put ("pair-with-position", - ClassType.make("gnu.lists.PairWithPosition")); - types.put ("constant-string", ClassType.make("java.lang.String")); - types.put ("abstract-string", ClassType.make("gnu.lists.CharSeq")); - types.put ("character", ClassType.make("gnu.text.Char")); - types.put ("vector", LangObjType.vectorType); - types.put ("string", LangObjType.stringType); - types.put ("empty-list", ClassType.make("gnu.lists.EmptyList")); - types.put ("list", LangObjType.listType); - types.put ("function", ClassType.make("gnu.mapping.Procedure")); - types.put ("procedure", LangObjType.procedureType); - types.put ("input-port", ClassType.make("gnu.mapping.InPort")); - types.put ("output-port", ClassType.make("gnu.mapping.OutPort")); - types.put ("string-output-port", - ClassType.make("gnu.mapping.CharArrayOutPort")); - types.put ("string-input-port", - ClassType.make("gnu.mapping.CharArrayInPort")); - types.put ("record", ClassType.make("kawa.lang.Record")); - types.put ("type", LangObjType.typeType); - types.put ("class-type", LangObjType.typeClassType); - types.put ("class", LangObjType.typeClass); - types.put ("promise", LangObjType.promiseType); - - for (int i = uniformVectorTags.length; --i >= 0; ) - { - String tag = uniformVectorTags[i]; - String cname = "gnu.lists."+tag.toUpperCase()+"Vector"; - types.put(tag+"vector", ClassType.make(cname)); - } - - types.put ("document", ClassType.make("gnu.kawa.xml.KDocument")); - types.put ("readtable", ClassType.make("gnu.kawa.lispexpr.ReadTable")); + String tag = uniformVectorTags[i]; + String cname = "gnu.lists." + tag.toUpperCase() + "Vector"; + types.put(tag + "vector", ClassType.make(cname)); } + + } return types; } - public static Type getNamedType (String name) + public Type getNamedType (String name) { - getTypeMap(); - Type type = (Type) types.get(name); - if (type == null - && (name.startsWith("elisp:") || name.startsWith("clisp:"))) - { - int colon = name.indexOf(':'); - Class clas = getNamedType(name.substring(colon+1)).getReflectClass(); - String lang = name.substring(0,colon); - Language interp = Language.getInstance(lang); - if (interp == null) - throw new RuntimeException("unknown type '" + name - + "' - unknown language '" - + lang + '\''); - type = interp.getTypeFor(clas); - if (type != null) - types.put(name, type); - } + Type type; + + type = getTypeMap().get(name); + + if (type == null) { + return LispLanguage.getNamedLispType(name); + } + return type; } - public Type getTypeFor (Class clas) - { - String name = clas.getName(); - if (clas.isPrimitive()) - return getNamedType(name); - if ("java.lang.String".equals(name)) - return Type.toStringType; - if ("gnu.math.IntNum".equals(name)) - return LangObjType.integerType; - if ("gnu.math.DFloNum".equals(name)) - return LangObjType.dflonumType; - if ("gnu.math.RatNum".equals(name)) - return LangObjType.rationalType; - if ("gnu.math.RealNum".equals(name)) - return LangObjType.realType; - if ("gnu.math.Numeric".equals(name)) - return LangObjType.numericType; - if ("gnu.lists.FVector".equals(name)) - return LangObjType.vectorType; - if ("gnu.lists.LList".equals(name)) - return LangObjType.listType; - if ("gnu.text.Path".equals(name)) - return LangObjType.pathType; - if ("gnu.text.URIPath".equals(name)) - return LangObjType.URIType; - if ("gnu.text.FilePath".equals(name)) - return LangObjType.filepathType; - if ("java.lang.Class".equals(name)) - return LangObjType.typeClass; - if ("gnu.bytecode.Type".equals(name)) - return LangObjType.typeType; - if ("gnu.bytecode.ClassType".equals(name)) - return LangObjType.typeClassType; - return Type.make(clas); + @Override + public Type getTypeFor (Class clas) { + Type type = super.getTypeFor(clas); + if (type == null) { + type = getTypeMap().get(clas.getName()); + } + return type; } + @Override public String formatType (Type type) { // FIXME synchronize @@ -1157,12 +1072,12 @@ t = ArrayType.make(t); } else - t = getNamedType (name); + t = getInstance().getNamedType (name); if (t != null) return t; t = Language.string2Type(name); if (t != null) - types.put (name, t); + getInstance().getTypeMap().put (name, t); return t; } @@ -1179,9 +1094,6 @@ return getInstance().getTypeFor(exp); } - public static final Namespace unitNamespace = - Namespace.valueOf("http://kawa.gnu.org/unit", "unit"); - public Symbol asSymbol (String ident) { return Namespace.EmptyNamespace.getSymbol(ident); Index: kawa/standard/define_unit.java =================================================================== --- kawa/standard/define_unit.java (revision 7247) +++ kawa/standard/define_unit.java (working copy) @@ -7,6 +7,7 @@ import gnu.expr.*; import gnu.math.*; import gnu.bytecode.*; +import gnu.kawa.lispexpr.LispLanguage; import gnu.mapping.*; public class define_unit extends Syntax @@ -34,7 +35,7 @@ if (q instanceof SimpleSymbol) { String name = q.toString(); - Symbol sym = Scheme.unitNamespace.getSymbol(name); + Symbol sym = LispLanguage.unitNamespace.getSymbol(name); Declaration decl = defs.getDefine(sym, 'w', tr); tr.push(decl); Translator.setLine(decl, p); Index: kawa/standard/SchemeCompilation.java =================================================================== --- kawa/standard/SchemeCompilation.java (revision 7247) +++ kawa/standard/SchemeCompilation.java (working copy) @@ -66,18 +66,12 @@ * {@code } and {@code java.lang.Integer}. * Also handles arrays, such as {@code java.lang.String[]}. */ + @Override public Expression checkDefaultBinding (Symbol symbol, Translator tr) { Namespace namespace = symbol.getNamespace(); String local = symbol.getLocalPart(); - if (namespace instanceof XmlNamespace) - return makeQuoteExp(((XmlNamespace) namespace).get(local)); - if (namespace.getName() == Scheme.unitNamespace.getName()) - { - Object val = Unit.lookup(local); - if (val != null) - return makeQuoteExp(val); - } + String name = symbol.toString(); int len = name.length(); if (len == 0) @@ -111,241 +105,8 @@ } } } - char ch0 = name.charAt(0); - - if (ch0 == '@') - { - String rest = name.substring(1); - Expression classRef = tr.rewrite(Symbol.valueOf(rest)); - return MakeAnnotation.makeAnnotationMaker(classRef); - } - - // Look for quantities. - if (ch0 == '-' || ch0 == '+' || Character.digit(ch0, 10) >= 0) - { - // 1: initial + or -1 seen. - // 2: digits seen - // 3: '.' seen - // 4: fraction seen - // 5: [eE][=+]?[0-9]+ seen - int state = 0; - int i = 0; - for (; i < len; i++) - { - char ch = name.charAt(i); - if (Character.digit(ch, 10) >= 0) - state = state < 3 ? 2 : state < 5 ? 4 : 5; - else if ((ch == '+' || ch == '-') && state == 0) - state = 1; - else if (ch == '.' && state < 3) - state = 3; - else if ((ch == 'e' || ch == 'E') && (state == 2 || state == 4) - && i + 1 < len) - { - int j = i+1; - char next = name.charAt(j); - if ((next == '-' || next == '+') && ++j < len) - next = name.charAt(j); - if (Character.digit(next, 10) < 0) - break; - state = 5; - i = j+1; - } - else - break; - } - tryQuantity: - if (i < len && state > 1) - { - DFloNum num = new DFloNum(name.substring(0,i)); - boolean div = false; - Vector vec = new Vector(); - for (; i < len ;) - { - char ch = name.charAt(i++); - if (ch == '*') - { - if (i == len) break tryQuantity; - ch = name.charAt(i++); - } - else if (ch == '/') - { - if (i == len || div) break tryQuantity; - div = true; - ch = name.charAt(i++); - } - int unitStart = i-1; - int unitEnd; - for (;;) - { - if (! Character.isLetter(ch)) - { - unitEnd = i - 1; - if (unitEnd == unitStart) - break tryQuantity; - break; - } - if (i == len) - { - unitEnd = i; - ch = '1'; - break; - } - ch = name.charAt(i++); - } - vec.addElement(name.substring(unitStart, unitEnd)); - boolean expRequired = false; - if (ch == '^') - { - expRequired = true; - if (i == len) break tryQuantity; - ch = name.charAt(i++); - } - boolean neg = div; - if (ch == '+') - { - expRequired = true; - if (i == len) break tryQuantity; - ch = name.charAt(i++); - } - else if (ch == '-') - { - expRequired = true; - if (i == len) break tryQuantity; - ch = name.charAt(i++); - neg = ! neg; - } - int nexp = 0; - int exp = 0; - for (;;) - { - int dig = Character.digit(ch, 10); - if (dig <= 0) - { - i--; - break; - } - exp = 10 * exp + dig; - nexp++; - if (i == len) - break; - ch = name.charAt(i++); - } - if (nexp == 0) - { - exp = 1; - if (expRequired) - break tryQuantity; - } - if (neg) - exp = - exp; - vec.addElement(IntNum.make(exp)); - } - if (i == len) - { - int nunits = vec.size() >> 1; - Expression[] units = new Expression[nunits]; - for (i = 0; i < nunits; i++) - { - String uname = (String) vec.elementAt(2*i); - Symbol usym = Scheme.unitNamespace.getSymbol(uname.intern()); - Expression uref = tr.rewrite(usym); - IntNum uexp = (IntNum) vec.elementAt(2*i+1); - if (uexp.longValue() != 1) - uref = new ApplyExp(expt.expt, - new Expression[] { uref , makeQuoteExp(uexp) }); - units[i] = uref; - } - Expression unit; - if (nunits == 1) - unit = units[0]; - else - unit = new ApplyExp(MultiplyOp.$St, units); - return new ApplyExp(MultiplyOp.$St, - new Expression[] { makeQuoteExp(num), - unit }); - } - } - } - - boolean sawAngle; - if (len > 2 && ch0 == '<' && name.charAt(len-1) == '>') - { - name = name.substring(1, len-1); - len -= 2; - sawAngle = true; - } - else - sawAngle = false; - int rank = 0; - while (len > 2 && name.charAt(len-2) == '[' && name.charAt(len-1) == ']') - { - len -= 2; - rank++; - } - - String cname = name; - if (rank != 0) - cname = name.substring(0, len); - try - { - Class clas; - Type type = Scheme.getNamedType(cname); - if (rank > 0 && (! sawAngle || type == null)) - { - Symbol tsymbol = namespace.getSymbol(cname.intern()); - Expression texp = tr.rewrite(tsymbol, false); - texp = InlineCalls.inlineCalls(texp, tr); - if (! (texp instanceof ErrorExp)) - type = tr.getLanguage().getTypeFor(texp); - } - if (type != null) - { - // Somewhat inconsistent: Types named by getNamedType are Type, - // while standard type/classes are Class. FIXME. - while (--rank >= 0) - type = gnu.bytecode.ArrayType.make(type); - return makeQuoteExp(type); - } - else - { - type = Type.lookupType(cname); - if (type instanceof gnu.bytecode.PrimType) - clas = type.getReflectClass(); - else - { - if (cname.indexOf('.') < 0) - cname = (tr.classPrefix - + Compilation.mangleNameIfNeeded(cname)); - clas = ClassType.getContextClass(cname); - } - } - if (clas != null) - { - if (rank > 0) - { - type = Type.make(clas); - while (--rank >= 0) - type = gnu.bytecode.ArrayType.make(type); - clas = type.getReflectClass(); - } - return makeQuoteExp(clas); - } - } - catch (ClassNotFoundException ex) - { - Package pack = gnu.bytecode.ArrayClassLoader.getContextPackage(name); - if (pack != null) - return makeQuoteExp(pack); - } - catch (NoClassDefFoundError ex) - { - tr.error('w', "error loading class "+cname+" - "+ex.getMessage()+" not found"); - } - catch (Throwable ex) - { - } - return null; + + return super.checkDefaultBinding(symbol, tr); }