Changeset 15569


Ignore:
Timestamp:
03/19/22 12:50:18 (13 months ago)
Author:
Mark Evenson
Message:

Untabify en masse

Results of running style.org source blocks on tree

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
140 edited

Legend:

Unmodified
Added
Removed

  • trunk/abcl/src/org/armedbear/lisp/AbstractString.java

    r13443 r15569  
    117117
    118118    public String toString() {
    119       int length = length();
    120       StringBuilder sb = new StringBuilder(length);
    121       for(int i = 0; i < length; ++i) {
    122       sb.append(charAt(i));
    123       }
    124       return sb.toString();
     119            int length = length();
     120            StringBuilder sb = new StringBuilder(length);
     121            for(int i = 0; i < length; ++i) {
     122                        sb.append(charAt(i));
     123            }
     124            return sb.toString();
    125125    }
    126126

  • trunk/abcl/src/org/armedbear/lisp/Autoload.java

    r15519 r15569  
    661661        autoload(Symbol.COPY_LIST, "copy_list");
    662662
    663   autoload(PACKAGE_SYS, "make-fasl-class-loader", "FaslClassLoader", false);
    664   autoload(PACKAGE_SYS, "get-fasl-function", "FaslClassLoader", false);
    665 
    666   autoload(PACKAGE_SYS, "make-memory-class-loader", "MemoryClassLoader", false);
    667   autoload(PACKAGE_SYS, "put-memory-function", "MemoryClassLoader", false);
    668   autoload(PACKAGE_SYS, "get-memory-function", "MemoryClassLoader", false);
     663        autoload(PACKAGE_SYS, "make-fasl-class-loader", "FaslClassLoader", false);
     664        autoload(PACKAGE_SYS, "get-fasl-function", "FaslClassLoader", false);
     665
     666        autoload(PACKAGE_SYS, "make-memory-class-loader", "MemoryClassLoader", false);
     667        autoload(PACKAGE_SYS, "put-memory-function", "MemoryClassLoader", false);
     668        autoload(PACKAGE_SYS, "get-memory-function", "MemoryClassLoader", false);
    669669
    670670        autoload(Symbol.SET_CHAR, "StringFunctions");

  • trunk/abcl/src/org/armedbear/lisp/ByteArrayOutputStream.java

    r15306 r15569  
    8989        if (elementType == NIL) {
    9090            return new byte[0];
    91   } else {
    92       return byteArrayOutputStream.toByteArray();
    93   }
     91        } else {
     92            return byteArrayOutputStream.toByteArray();
     93        }
    9494    }
    9595

  • trunk/abcl/src/org/armedbear/lisp/CharHashMap.java

    r12429 r15569  
    1313public class CharHashMap<T> {
    1414
    15   final public T[] constants;
    16   final public T NULL;
    17   final static int CACHE_SIZE = 256;
    18   final HashMap<Character, T> backing;
     15        final public T[] constants;
     16        final public T NULL;
     17        final static int CACHE_SIZE = 256;
     18        final HashMap<Character, T> backing;
    1919
    2020        @SuppressWarnings("unchecked")
    21   public CharHashMap(Class componentType, T def) {
    22     NULL = def;
    23     constants = (T[]) Array.newInstance(componentType, CACHE_SIZE);
    24     Arrays.fill(constants, NULL);
    25     backing = new HashMap<Character, T>();
    26   }
    27  
    28   @Override
    29   public Object clone() {
    30     CharHashMap<T> n = new CharHashMap<T>(constants.getClass().getComponentType(),NULL);
    31     System.arraycopy(constants,0, n.constants,0,CACHE_SIZE);
    32     n.backing.putAll(backing);
    33     return n;
    34   }
    35  
    36   public T get(char key) {
    37     if (key<CACHE_SIZE) return constants[key];
    38     T value = backing.get(key);
    39     return (value==null) ? NULL:value;
    40   }
     21        public CharHashMap(Class componentType, T def) {
     22                NULL = def;
     23                constants = (T[]) Array.newInstance(componentType, CACHE_SIZE);
     24                Arrays.fill(constants, NULL);
     25                backing = new HashMap<Character, T>();
     26        }
     27       
     28        @Override
     29        public Object clone() {
     30                CharHashMap<T> n = new CharHashMap<T>(constants.getClass().getComponentType(),NULL);
     31                System.arraycopy(constants,0, n.constants,0,CACHE_SIZE);
     32                n.backing.putAll(backing);
     33                return n;
     34        }
     35       
     36        public T get(char key) {
     37                if (key<CACHE_SIZE) return constants[key];
     38                T value = backing.get(key);
     39                return (value==null) ? NULL:value;
     40        }
    4141
    42   public void clear() {
    43     Arrays.fill(constants,NULL);
    44     backing.clear();
    45   }
     42        public void clear() {
     43                Arrays.fill(constants,NULL);
     44                backing.clear();
     45        }
    4646
    47   public T put(char key, T value) {
    48     if (key<CACHE_SIZE) {
    49       T old = constants[key];
    50       constants[key] = value;
    51       return old;
    52     }
    53     else return backing.put(key, value);
    54   }
     47        public T put(char key, T value) {
     48                if (key<CACHE_SIZE) {
     49                        T old = constants[key];
     50                        constants[key] = value;
     51                        return old;
     52                }
     53                else return backing.put(key, value);
     54        }
    5555
    56   public Iterator<Character> getCharIterator() {
    57     return new Iterator<Character>() {     
    58       final Iterator<Character> carIt =  backing.keySet().iterator();
    59       int charNum = -1;
    60       public boolean hasNext() {
    61         if ( charNum<CACHE_SIZE) return true;
    62         return carIt.hasNext();
    63       }
    64       public Character next() {
    65         if ( charNum<CACHE_SIZE) return (char)++charNum;
    66         return carIt.next();
    67       }
    68       public void remove() {
    69         throw new UnsupportedOperationException();     
    70       }
    71      
    72     };
    73   }
     56        public Iterator<Character> getCharIterator() {
     57                return new Iterator<Character>() {                     
     58                        final Iterator<Character> carIt =  backing.keySet().iterator();
     59                        int charNum = -1;
     60                        public boolean hasNext() {
     61                                if ( charNum<CACHE_SIZE) return true;
     62                                return carIt.hasNext();
     63                        }
     64                        public Character next() {
     65                                if ( charNum<CACHE_SIZE) return (char)++charNum;
     66                                return carIt.next();
     67                        }
     68                        public void remove() {
     69                                throw new UnsupportedOperationException();                     
     70                        }
     71                       
     72                };
     73        }
    7474}

  • trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java

    r14023 r15569  
    6363      CompiledClosure result = null;
    6464      try {
    65     result = (CompiledClosure)super.clone();
     65          result = (CompiledClosure)super.clone();
    6666      } catch (CloneNotSupportedException e) {
    6767      }
    … …  
    226226        namestring = arg.getStringValue();
    227227      if(arg instanceof JavaObject) {
    228     try {
    229         return loadClassBytes((byte[]) arg.javaInstance(byte[].class));
    230     } catch(Throwable t) {
    231         Debug.trace(t);
    232         return error(new LispError("Unable to load " + arg.princToString()));
    233     }
     228          try {
     229              return loadClassBytes((byte[]) arg.javaInstance(byte[].class));
     230          } catch(Throwable t) {
     231              Debug.trace(t);
     232              return error(new LispError("Unable to load " + arg.princToString()));
     233          }
    234234      }
    235235      return error(new LispError("Unable to load " + arg.princToString()));

  • trunk/abcl/src/org/armedbear/lisp/ConcatenatedStream.java

    r15138 r15569  
    115115                return eofValue;
    116116        }
    117   try
    118     {
    119       return _charReady() ? readChar(eofError, eofValue) : NIL;
    120     }
    121   catch (java.io.IOException e)
    122     {
    123       return error(new StreamError(this, e));
    124     }
     117        try
     118          {
     119            return _charReady() ? readChar(eofError, eofValue) : NIL;
     120          }
     121        catch (java.io.IOException e)
     122          {
     123            return error(new StreamError(this, e));
     124          }
    125125    }
    126126

  • trunk/abcl/src/org/armedbear/lisp/Debug.java

    r15031 r15569  
    4848            Error e = new Error(msg);
    4949            e.printStackTrace(System.err);
    50      
    51       StringBuffer buffer = new StringBuffer();
    52       final String CR = "\n";
    53       buffer.append(msg).append(CR);
    54       StackTraceElement[] stack = e.getStackTrace();
    55       for (int i = 0; i < stack.length; i++) {
    56     buffer.append(stack[i].toString()).append(CR);
    57       }
     50           
     51            StringBuffer buffer = new StringBuffer();
     52            final String CR = "\n";
     53            buffer.append(msg).append(CR);
     54            StackTraceElement[] stack = e.getStackTrace();
     55            for (int i = 0; i < stack.length; i++) {
     56                buffer.append(stack[i].toString()).append(CR);
     57            }
    5858            throw new Error(buffer.toString());
    5959        }

  • trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java

    r15406 r15569  
    6565
    6666            if (c == null && checkPreCompiledClassLoader) {
    67               c = findPrecompiledClassOrNull(name);
    68               // Oh, we have to return here so we don't become the owning class loader?
    69               if (c != null)
     67                c = findPrecompiledClassOrNull(name);
     68                // Oh, we have to return here so we don't become the owning class loader?
     69                if (c != null)
    7070                  return c;
    7171            }           
    … …  
    8989        try {
    9090            if (checkPreCompiledClassLoader) {
    91               Class<?> c = findPrecompiledClassOrNull(name);
    92               if (c != null)
    93                 return c;                 
     91                Class<?> c = findPrecompiledClassOrNull(name);
     92                if (c != null)
     93                        return c;                       
    9494            }
    9595            byte[] b = getFunctionClassBytes(name);
    … …  
    156156    private static final Primitive GET_FASL_FUNCTION = new pf_get_fasl_function();
    157157    private static final class pf_get_fasl_function extends Primitive {
    158   pf_get_fasl_function() {
     158        pf_get_fasl_function() {
    159159            super("get-fasl-function", PACKAGE_SYS, false, "loader function-number");
    160160        }
    … …  
    163163        public LispObject execute(LispObject loader, LispObject fnNumber) {
    164164            FaslClassLoader l = (FaslClassLoader) loader.javaInstance(FaslClassLoader.class);
    165       return l.loadFunction(fnNumber.intValue());
     165            return l.loadFunction(fnNumber.intValue());
    166166        }
    167167    };

  • trunk/abcl/src/org/armedbear/lisp/FaslReadtable.java

    r13187 r15569  
    4444    protected void initialize()
    4545    {
    46       Byte[] syntax = this.syntax.constants;
     46        Byte[] syntax = this.syntax.constants;
    4747        syntax[9]    = SYNTAX_TYPE_WHITESPACE; // tab
    4848        syntax[10]   = SYNTAX_TYPE_WHITESPACE; // linefeed

  • trunk/abcl/src/org/armedbear/lisp/FileStream.java

    r15447 r15569  
    8888        Debug.assertTrue(mode != null);
    8989        RandomAccessFile raf = new RandomAccessFile(file, mode);
    90  
     90       
    9191        // ifExists is ignored unless we have an output stream.
    9292        if (isOutputStream) {
    … …  
    103103        setExternalFormat(format);
    104104       
    105   // don't touch raf directly after passing it to racf.
    106   // the state will become inconsistent if you do that.
     105        // don't touch raf directly after passing it to racf.
     106        // the state will become inconsistent if you do that.
    107107        racf = new RandomAccessCharacterFile(raf, encoding);
    108108
    … …  
    112112            isCharacterStream = true;
    113113            bytesPerUnit = 1;
    114       if (isInputStream) {
    115     initAsCharacterInputStream(racf.getReader());
    116       }
    117       if (isOutputStream) {
    118     initAsCharacterOutputStream(racf.getWriter());
    119       }
     114            if (isInputStream) {
     115                initAsCharacterInputStream(racf.getReader());
     116            }
     117            if (isOutputStream) {
     118                initAsCharacterOutputStream(racf.getWriter());
     119            }
    120120        } else {
    121121            isBinaryStream = true;
    122122            int width = Fixnum.getValue(elementType.cadr());
    123123            bytesPerUnit = width / 8;
    124       if (isInputStream) {
    125     initAsBinaryInputStream(racf.getInputStream());
    126       }
    127       if (isOutputStream) {
    128     initAsBinaryOutputStream(racf.getOutputStream());
    129       }
     124            if (isInputStream) {
     125                initAsBinaryInputStream(racf.getInputStream());
     126            }
     127            if (isOutputStream) {
     128                initAsBinaryOutputStream(racf.getOutputStream());
     129            }
    130130        }
    131131    }
    … …  
    205205    {
    206206        try {
    207       if (isInputStream) {
    208     racf.position(racf.length());
    209       } else {
    210     streamNotInputStream();
    211       }
     207            if (isInputStream) {
     208                racf.position(racf.length());
     209            } else {
     210                streamNotInputStream();
     211            }
    212212        }
    213213        catch (IOException e) {

  • trunk/abcl/src/org/armedbear/lisp/Function.java

    r15365 r15569  
    5151
    5252    protected Function() {
    53   LispObject loadTruename = Symbol.LOAD_TRUENAME.symbolValueNoThrow();
    54   LispObject loadTruenameFasl = Symbol.LOAD_TRUENAME_FASL.symbolValueNoThrow();
    55   loadedFrom = loadTruenameFasl != null ? loadTruenameFasl : (loadTruename != null ? loadTruename : NIL);
     53        LispObject loadTruename = Symbol.LOAD_TRUENAME.symbolValueNoThrow();
     54        LispObject loadTruenameFasl = Symbol.LOAD_TRUENAME_FASL.symbolValueNoThrow();
     55        loadedFrom = loadTruenameFasl != null ? loadTruenameFasl : (loadTruename != null ? loadTruename : NIL);
    5656    }
    5757
    … …  
    6363    public Function(String name, String arglist)
    6464    {
    65   this();
     65        this();
    6666        if(arglist != null)
    6767            setLambdaList(new SimpleString(arglist));
    … …  
    7676    public Function(Symbol symbol)
    7777    {
    78   this(symbol, null, null);
     78        this(symbol, null, null);
    7979    }
    8080
    8181    public Function(Symbol symbol, String arglist)
    8282    {
    83   this(symbol, arglist, null);
     83        this(symbol, arglist, null);
    8484    }
    8585
    8686    public Function(Symbol symbol, String arglist, String docstring)
    8787    {
    88   this();
     88        this();
    8989        symbol.setSymbolFunction(this);
    9090        if (cold)
    … …  
    117117                    String arglist, String docstring)
    118118    {
    119   this();
     119        this();
    120120        if (arglist instanceof String)
    121121            setLambdaList(new SimpleString(arglist));
    … …  
    138138    public Function(LispObject name)
    139139    {
    140   this();
     140        this();
    141141        setLambdaName(name);
    142142    }
    … …  
    144144    public Function(LispObject name, LispObject lambdaList)
    145145    {
    146   this();
     146        this();
    147147        setLambdaName(name);
    148148        setLambdaList(lambdaList);
    … …  
    226226    public static final Primitive FUNCTION_CLASS_BYTES = new pf_function_class_bytes();
    227227    public static final class pf_function_class_bytes extends Primitive {
    228   public pf_function_class_bytes() {
    229       super("function-class-bytes", PACKAGE_SYS, false, "function");
     228        public pf_function_class_bytes() {
     229            super("function-class-bytes", PACKAGE_SYS, false, "function");
    230230        }
    231231        @Override
    … …  
    233233            if (arg instanceof Function) {
    234234                return ((Function) arg).getClassBytes();
    235       }
     235            }
    236236            return type_error(arg, Symbol.FUNCTION);
    237237        }

  • trunk/abcl/src/org/armedbear/lisp/HashTableFunctions.java

    r14466 r15569  
    8787                                LispObject rehashSize,
    8888                                LispObject rehashThreshold,
    89         LispObject weakness)
     89                                LispObject weakness)
    9090      {
    9191        final int n = Fixnum.getValue(size);
    9292        if (test == FUNCTION_EQL || test == NIL)
    9393          return WeakHashTable.newEqlHashTable(n, rehashSize,
    94                  rehashThreshold, weakness);
     94                                               rehashThreshold, weakness);
    9595        if (test == FUNCTION_EQ)
    9696          return WeakHashTable.newEqHashTable(n, rehashSize,
    … …  
    9898        if (test == FUNCTION_EQUAL)
    9999          return WeakHashTable.newEqualHashTable(n, rehashSize,
    100             rehashThreshold, weakness);
     100                                                rehashThreshold, weakness);
    101101        if (test == FUNCTION_EQUALP)
    102102          return WeakHashTable.newEqualpHashTable(n, rehashSize,
    103               rehashThreshold, weakness);
     103                                                  rehashThreshold, weakness);
    104104        return error(new LispError("Unsupported test for MAKE-HASH-TABLE: " +
    105105                                    test.princToString()));

  • trunk/abcl/src/org/armedbear/lisp/JProxy.java

    r15521 r15569  
    131131  }
    132132 
    133     //NEW IMPLEMENTATION by Alessio Stalla
    134  
    135     /**
    136     * A weak map associating each proxy instance with a "Lisp-this" object.
    137     */
    138     static final Map<Object, LispObject> proxyMap = new WeakHashMap<Object, LispObject>();
     133        //NEW IMPLEMENTATION by Alessio Stalla
     134 
     135        /**
     136        * A weak map associating each proxy instance with a "Lisp-this" object.
     137        */
     138        static final Map<Object, LispObject> proxyMap = new WeakHashMap<Object, LispObject>();
    139139 
    140140    public static class LispInvocationHandler implements InvocationHandler {
    141  
    142   private Function function;
    143   private static Method hashCodeMethod;
    144   private static Method equalsMethod;
    145   private static Method toStringMethod;
    146    
    147   static {
    148       try {
    149     hashCodeMethod = Object.class.getMethod("hashCode", new Class[] {});
    150     equalsMethod = Object.class.getMethod("equals", new Class[] { Object.class });
    151     toStringMethod = Object.class.getMethod("toString", new Class[] {});
    152       } catch (Exception e) {
    153     throw new Error("Something got horribly wrong - can't get a method from Object.class", e);
    154       }
    155   }
    156  
    157   public LispInvocationHandler(Function function) {
    158       this.function = function;
    159   }
    160      
    161   public Object invoke(Object proxy, Method method, Object[] args) throws Throwable {
    162       if(hashCodeMethod.equals(method)) {
    163     return System.identityHashCode(proxy);
    164       }
    165       if(equalsMethod.equals(method)) {
    166     return proxy == args[0];
    167       }
    168       if(toStringMethod.equals(method)) {
    169     return proxy.getClass().getName() + '@' + Integer.toHexString(proxy.hashCode());
    170       }
    171        
    172       if(args == null) {
    173     args = new Object[0];
    174       }
    175       LispObject lispArgs = NIL;
    176       synchronized(proxyMap) {
    177     lispArgs = lispArgs.push(toLispObject(proxyMap.get(proxy)));
    178       }
    179       lispArgs = lispArgs.push(new SimpleString(method.getName()));
    180       for(int i = 0; i < args.length; i++) {
    181     lispArgs = lispArgs.push(toLispObject(args[i]));
    182       }
    183       Object retVal =
    184     LispThread.currentThread().execute
    185     (Symbol.APPLY, function, lispArgs.reverse()).javaInstance();
    186       //(function.execute(lispArgs)).javaInstance();
    187       /* DOES NOT WORK due to autoboxing!
    188          if(retVal != null && !method.getReturnType().isAssignableFrom(retVal.getClass())) {
    189          return error(new TypeError(new JavaObject(retVal), new JavaObject(method.getReturnType())));
    190          }*/
    191       return retVal;
    192   }
    193     }
    194  
    195     private static final Primitive _JMAKE_INVOCATION_HANDLER =
    196       new Primitive("%jmake-invocation-handler", PACKAGE_JAVA, false,
    197                     "function") {
    198    
    199           public LispObject execute(LispObject[] args) {
    200             int length = args.length;
    201             if (length != 1) {
    202               return error(new WrongNumberOfArgumentsException(this, 1));
    203             }
    204             if(!(args[0] instanceof Function)) {
    205               return type_error(args[0], Symbol.FUNCTION);
    206             }
    207             return new JavaObject(new LispInvocationHandler((Function) args[0]));
    208           }
    209       };
     141       
     142        private Function function;
     143        private static Method hashCodeMethod;
     144        private static Method equalsMethod;
     145        private static Method toStringMethod;
     146       
     147        static {
     148            try {
     149                hashCodeMethod = Object.class.getMethod("hashCode", new Class[] {});
     150                equalsMethod = Object.class.getMethod("equals", new Class[] { Object.class });
     151                toStringMethod = Object.class.getMethod("toString", new Class[] {});
     152            } catch (Exception e) {
     153                throw new Error("Something got horribly wrong - can't get a method from Object.class", e);
     154            }
     155        }
     156       
     157        public LispInvocationHandler(Function function) {
     158            this.function = function;
     159        }
     160               
     161        public Object invoke(Object proxy, Method method, Object[] args) throws Throwable {
     162            if(hashCodeMethod.equals(method)) {
     163                return System.identityHashCode(proxy);
     164            }
     165            if(equalsMethod.equals(method)) {
     166                return proxy == args[0];
     167            }
     168            if(toStringMethod.equals(method)) {
     169                return proxy.getClass().getName() + '@' + Integer.toHexString(proxy.hashCode());
     170            }
     171               
     172            if(args == null) {
     173                args = new Object[0];
     174            }
     175            LispObject lispArgs = NIL;
     176            synchronized(proxyMap) {
     177                lispArgs = lispArgs.push(toLispObject(proxyMap.get(proxy)));
     178            }
     179            lispArgs = lispArgs.push(new SimpleString(method.getName()));
     180            for(int i = 0; i < args.length; i++) {
     181                lispArgs = lispArgs.push(toLispObject(args[i]));
     182            }
     183            Object retVal =
     184                LispThread.currentThread().execute
     185                (Symbol.APPLY, function, lispArgs.reverse()).javaInstance();
     186            //(function.execute(lispArgs)).javaInstance();
     187            /* DOES NOT WORK due to autoboxing!
     188               if(retVal != null && !method.getReturnType().isAssignableFrom(retVal.getClass())) {
     189               return error(new TypeError(new JavaObject(retVal), new JavaObject(method.getReturnType())));
     190               }*/
     191            return retVal;
     192        }
     193    }
     194 
     195        private static final Primitive _JMAKE_INVOCATION_HANDLER =
     196            new Primitive("%jmake-invocation-handler", PACKAGE_JAVA, false,
     197                          "function") {
     198               
     199                public LispObject execute(LispObject[] args) {
     200                        int length = args.length;
     201                        if (length != 1) {
     202                                return error(new WrongNumberOfArgumentsException(this, 1));
     203                        }
     204                        if(!(args[0] instanceof Function)) {
     205                                return type_error(args[0], Symbol.FUNCTION);
     206                        }
     207                        return new JavaObject(new LispInvocationHandler((Function) args[0]));
     208                }
     209            };
    210210
    211211    private static final Primitive _JMAKE_PROXY =
    212       new Primitive("%jmake-proxy", PACKAGE_JAVA, false,
    213                     "interfaces invocation-handler") {
    214    
    215           public LispObject execute(final LispObject[] args) {
    216             int length = args.length;
    217             if (length != 3) {
    218               return error(new WrongNumberOfArgumentsException(this, 3));
    219             }
    220             if(!(args[0] instanceof Cons)) {
    221           return type_error(args[0], Symbol.CONS);
    222             }
    223       Class[] ifaces = new Class[args[0].length()];
    224       LispObject ifList = args[0];
    225       for(int i = 0; i < ifaces.length; i++) {
     212            new Primitive("%jmake-proxy", PACKAGE_JAVA, false,
     213                          "interfaces invocation-handler") {
     214               
     215                public LispObject execute(final LispObject[] args) {
     216                        int length = args.length;
     217                        if (length != 3) {
     218                                return error(new WrongNumberOfArgumentsException(this, 3));
     219                        }
     220                        if(!(args[0] instanceof Cons)) {
     221                            return type_error(args[0], Symbol.CONS);
     222                        }
     223                        Class[] ifaces = new Class[args[0].length()];
     224                        LispObject ifList = args[0];
     225                        for(int i = 0; i < ifaces.length; i++) {
    226226                          ifaces[i] = (Class) ifList.car().javaInstance(Class.class);
    227           ifList = ifList.cdr();
    228       }
    229             InvocationHandler invocationHandler = (InvocationHandler) ((JavaObject) args[1]).javaInstance(InvocationHandler.class);
    230             Object proxy = Proxy.newProxyInstance(
    231                 JavaClassLoader.getCurrentClassLoader(),
    232                 ifaces,
    233                 invocationHandler);
    234             synchronized(proxyMap) {
    235               proxyMap.put(proxy, args[2]);
    236             }
    237             return new JavaObject(proxy);
    238           }
    239       };   
    240      
    241   static LispObject toLispObject(Object obj) {
    242     return (obj instanceof LispObject) ? (LispObject) obj : new JavaObject(obj);
    243   }
    244      
     227                            ifList = ifList.cdr();
     228                        }
     229                        InvocationHandler invocationHandler = (InvocationHandler) ((JavaObject) args[1]).javaInstance(InvocationHandler.class);
     230                        Object proxy = Proxy.newProxyInstance(
     231                                        JavaClassLoader.getCurrentClassLoader(),
     232                                        ifaces,
     233                                        invocationHandler);
     234                        synchronized(proxyMap) {
     235                                proxyMap.put(proxy, args[2]);
     236                        }
     237                        return new JavaObject(proxy);
     238                }
     239            };   
     240           
     241        static LispObject toLispObject(Object obj) {
     242                return (obj instanceof LispObject) ? (LispObject) obj : new JavaObject(obj);
     243        }
     244           
    245245}

  • trunk/abcl/src/org/armedbear/lisp/JarPathname.java

    r15493 r15569  
    387387      Pathname withoutDevice = new Pathname();
    388388      withoutDevice
    389   .copyFrom(this)
     389        .copyFrom(this)
    390390        .setDevice(NIL);
    391391
    … …  
    425425
    426426  public static LispObject truename(Pathname pathname,
    427             boolean errorIfDoesNotExist) {
     427                                    boolean errorIfDoesNotExist) {
    428428    if (!(pathname instanceof JarPathname)) {
    429429      return URLPathname.truename(pathname, errorIfDoesNotExist);
    … …  
    452452      LispObject rootJarTruename = Pathname.truename(rootJar, errorIfDoesNotExist);
    453453      if (rootJarTruename.equals(NIL)) {
    454   return Pathname.doTruenameExit(rootJar, errorIfDoesNotExist);
     454        return Pathname.doTruenameExit(rootJar, errorIfDoesNotExist);
    455455      }
    456456      LispObject otherJars = p.getJars().cdr();

  • trunk/abcl/src/org/armedbear/lisp/Java.java

    r15511 r15569  
    151151        public LispObject execute(LispObject arg)
    152152        {
    153       return JavaObject.getInstance(javaClass(arg, JavaClassLoader.getCurrentClassLoader()));
     153            return JavaObject.getInstance(javaClass(arg, JavaClassLoader.getCurrentClassLoader()));
    154154        }
    155155
    … …  
    157157        public LispObject execute(LispObject className, LispObject classLoader)
    158158        {
    159       ClassLoader loader = (ClassLoader) classLoader.javaInstance(ClassLoader.class);
    160       return JavaObject.getInstance(javaClass(className, loader));
     159            ClassLoader loader = (ClassLoader) classLoader.javaInstance(ClassLoader.class);
     160            return JavaObject.getInstance(javaClass(className, loader));
    161161        }
    162162    };
    … …  
    588588            try {
    589589                Constructor constructor;
    590     if(classRef instanceof AbstractString) {
    591         constructor = findConstructor(javaClass(classRef), args);
    592     } else {
    593         Object object = JavaObject.getObject(classRef);
    594         if(object instanceof Constructor) {
    595       constructor = (Constructor) object;
    596         } else if(object instanceof Class<?>) {
    597       constructor = findConstructor((Class<?>) object, args);
    598         } else {
    599       return error(new LispError(classRef.princToString() + " is neither a Constructor nor a Class"));
    600         }
    601     }
     590                if(classRef instanceof AbstractString) {
     591                    constructor = findConstructor(javaClass(classRef), args);
     592                } else {
     593                    Object object = JavaObject.getObject(classRef);
     594                    if(object instanceof Constructor) {
     595                        constructor = (Constructor) object;
     596                    } else if(object instanceof Class<?>) {
     597                        constructor = findConstructor((Class<?>) object, args);
     598                    } else {
     599                        return error(new LispError(classRef.princToString() + " is neither a Constructor nor a Class"));
     600                    }
     601                }
    602602                Class[] argTypes = constructor.getParameterTypes();
    603603                Object[] initargs = new Object[args.length-1];
    … …  
    936936                method = (Method) JavaObject.getObject(methodArg);
    937937            Class<?>[] argTypes = (Class<?>[])method.getParameterTypes();
    938       if(argTypes.length != args.length - 2) {
    939     return error(new WrongNumberOfArgumentsException("Wrong number of arguments for " + method + ": expected " + argTypes.length + ", got " + (args.length - 2)));
    940       }
     938            if(argTypes.length != args.length - 2) {
     939                return error(new WrongNumberOfArgumentsException("Wrong number of arguments for " + method + ": expected " + argTypes.length + ", got " + (args.length - 2)));
     940            }
    941941            methodArgs = new Object[argTypes.length];
    942942            for (int i = 2; i < args.length; i++) {
    … …  
    953953                 // Possible for static member classes: see #229
    954954                 if (Modifier.isPublic(method.getModifiers())) {
    955                     method.setAccessible(true);
     955                      method.setAccessible(true);
    956956                 }
    957       }
     957            }
    958958            return JavaObject.getInstance(method.invoke(instance, methodArgs),
    959959                                          translate,
    … …  
    982982
    983983    private static Object[] translateMethodArguments(LispObject[] args) {
    984   return translateMethodArguments(args, 0);
     984        return translateMethodArguments(args, 0);
    985985    }
    986986
    987987    private static Object[] translateMethodArguments(LispObject[] args, int offs) {
    988   int argCount = args.length - offs;
     988        int argCount = args.length - offs;
    989989        Object[] javaArgs = new Object[argCount];
    990990        for (int i = 0; i < argCount; ++i) {
    … …  
    998998          }
    999999        }
    1000   return javaArgs;
     1000        return javaArgs;
    10011001    }
    10021002
    … …  
    10331033            if(intendedClass != actualClass) {
    10341034                method = findMethod(actualClass, methodName, methodArgs);
    1035     if (method != null) {
    1036        if (isMethodCallableOnInstance(actualClass, method)) {
    1037           return method;
    1038        }
    1039     }
     1035                if (method != null) {
     1036                   if (isMethodCallableOnInstance(actualClass, method)) {
     1037                      return method;
     1038                   }
     1039                }
    10401040            }
    10411041        }
    … …  
    10451045    private static boolean isMethodCallableOnInstance(Class instance, Method method) {
    10461046       if (Modifier.isPublic(method.getModifiers())) {
    1047     return true;
     1047          return true;
    10481048       }
    10491049       if (instance.isMemberClass()) {
    1050     return isMethodCallableOnInstance(instance.getEnclosingClass(), method);
     1050          return isMethodCallableOnInstance(instance.getEnclosingClass(), method);
    10511051       }
    10521052       return false;
    … …  
    10871087        }
    10881088        if (result == null) {
    1089       StringBuilder sb = new StringBuilder(c.getSimpleName());
    1090       sb.append('(');
    1091       boolean first = true;
    1092       for(Object o : javaArgs) {
    1093     if(first) {
    1094         first = false;
    1095     } else {
    1096         sb.append(", ");
    1097     }
    1098     if(o != null) {
    1099         sb.append(o.getClass().getName());
    1100     } else {
    1101         sb.append("<null>");
    1102     }
    1103       }
    1104       sb.append(')');
     1089            StringBuilder sb = new StringBuilder(c.getSimpleName());
     1090            sb.append('(');
     1091            boolean first = true;
     1092            for(Object o : javaArgs) {
     1093                if(first) {
     1094                    first = false;
     1095                } else {
     1096                    sb.append(", ");
     1097                }
     1098                if(o != null) {
     1099                    sb.append(o.getClass().getName());
     1100                } else {
     1101                    sb.append("<null>");
     1102                }
     1103            }
     1104            sb.append(')');
    11051105            throw new NoSuchMethodException(sb.toString());
    11061106        }
    … …  
    12031203
    12041204    public static Class<?> maybeBoxClass(Class<?> clazz) {
    1205   if(clazz.isPrimitive()) {
    1206       return getBoxedClass(clazz);
    1207   } else {
    1208       return clazz;
    1209   }
     1205        if(clazz.isPrimitive()) {
     1206            return getBoxedClass(clazz);
     1207        } else {
     1208            return clazz;
     1209        }
    12101210    }
    12111211   
    … …  
    13521352        public LispObject execute(LispObject javaObject, LispObject intendedClass)
    13531353        {
    1354       Object o = javaObject.javaInstance();
    1355       Class<?> c = javaClass(intendedClass);
    1356       try {
    1357     return JavaObject.getInstance(o, c);
    1358       } catch(ClassCastException e) {
     1354            Object o = javaObject.javaInstance();
     1355            Class<?> c = javaClass(intendedClass);
     1356            try {
     1357                return JavaObject.getInstance(o, c);
     1358            } catch(ClassCastException e) {
    13591359          return type_error(javaObject, new SimpleString(c.getName()));
    1360       }
     1360            }
    13611361        }
    13621362    };
    … …  
    13911391
    13921392    private static Class classForName(String className) {
    1393   return classForName(className, JavaClassLoader.getPersistentInstance());
     1393        return classForName(className, JavaClassLoader.getPersistentInstance());
    13941394    }
    13951395
    … …  
    14311431
    14321432    private static Class javaClass(LispObject obj) {
    1433   return javaClass(obj, JavaClassLoader.getCurrentClassLoader());
     1433        return javaClass(obj, JavaClassLoader.getCurrentClassLoader());
    14341434    }
    14351435
    … …  
    14571457            // Not a primitive Java type.
    14581458            Class c;
    1459       c = classForName(s, classLoader);
     1459            c = classForName(s, classLoader);
    14601460            if (c == null)
    14611461                error(new LispError(s + " does not designate a Java class."));

  • trunk/abcl/src/org/armedbear/lisp/JavaBeans.java

    r14326 r15569  
    5151        pf__jget_property_value()
    5252        {
    53       super("%jget-property-value", PACKAGE_JAVA, false,
     53            super("%jget-property-value", PACKAGE_JAVA, false,
    5454                  "java-object property-name");
    5555        }
    56      
     56       
    5757        @Override
    5858        public LispObject execute(LispObject javaObject, LispObject propertyName) {
    59       try {
    60         Object obj = javaObject.javaInstance();
    61         PropertyDescriptor pd = getPropertyDescriptor(obj, propertyName);
    62         Object value = pd.getReadMethod().invoke(obj);
    63         if(value instanceof LispObject) {
    64             return (LispObject) value;
    65         } else if(value != null) {
    66             return JavaObject.getInstance(value, true);
    67         } else {
    68             return NIL;
    69         }
    70       } catch (Exception e) {
     59                        try {
     60                                Object obj = javaObject.javaInstance();
     61                                PropertyDescriptor pd = getPropertyDescriptor(obj, propertyName);
     62                                Object value = pd.getReadMethod().invoke(obj);
     63                                if(value instanceof LispObject) {
     64                                    return (LispObject) value;
     65                                } else if(value != null) {
     66                                    return JavaObject.getInstance(value, true);
     67                                } else {
     68                                    return NIL;
     69                                }
     70                        } catch (Exception e) {
    7171                return error(new JavaException(e));
    72       }
     72                        }
    7373        }
    7474    };
    … …  
    8282        pf__jset_property_value()
    8383        {
    84       super("%jset-property-value", PACKAGE_JAVA, false,
     84            super("%jset-property-value", PACKAGE_JAVA, false,
    8585                  "java-object property-name value");
    8686        }
    87      
     87       
    8888        @Override
    8989        public LispObject execute(LispObject javaObject, LispObject propertyName, LispObject value) {
    90       Object obj = null;
    91       try {
    92     obj = javaObject.javaInstance();
    93     PropertyDescriptor pd = getPropertyDescriptor(obj, propertyName);
    94     Object jValue;
    95     //TODO maybe we should do this in javaInstance(Class)
    96     if(value instanceof JavaObject) {
    97         jValue = value.javaInstance();
    98     } else {
    99         if(Boolean.TYPE.equals(pd.getPropertyType()) ||
    100            Boolean.class.equals(pd.getPropertyType())) {
    101       jValue = value != NIL;
    102         } else {
    103       jValue = value != NIL ? value.javaInstance() : null;
    104         }
    105     }
    106     pd.getWriteMethod().invoke(obj, jValue);
    107     return value;
    108       } catch (Exception e) {
     90            Object obj = null;
     91            try {
     92                obj = javaObject.javaInstance();
     93                PropertyDescriptor pd = getPropertyDescriptor(obj, propertyName);
     94                Object jValue;
     95                //TODO maybe we should do this in javaInstance(Class)
     96                if(value instanceof JavaObject) {
     97                    jValue = value.javaInstance();
     98                } else {
     99                    if(Boolean.TYPE.equals(pd.getPropertyType()) ||
     100                       Boolean.class.equals(pd.getPropertyType())) {
     101                        jValue = value != NIL;
     102                    } else {
     103                        jValue = value != NIL ? value.javaInstance() : null;
     104                    }
     105                }
     106                pd.getWriteMethod().invoke(obj, jValue);
     107                return value;
     108            } catch (Exception e) {
    109109            return error(new JavaException(e));
    110       }
     110            }
    111111        }
    112112    };
    … …  
    116116        BeanInfo beanInfo = Introspector.getBeanInfo(obj.getClass());
    117117        for(PropertyDescriptor pd : beanInfo.getPropertyDescriptors()) {
    118           if(pd.getName().equals(prop)) {
    119             return pd;
    120           }
     118                if(pd.getName().equals(prop)) {
     119                        return pd;
     120                }
    121121        }
    122122        error(new LispError("Property " + prop + " not found in " + obj));

  • trunk/abcl/src/org/armedbear/lisp/JavaObject.java

    r15363 r15569  
    371371                = new StringBuilder(c.isArray() ? "jarray" : c.getName());
    372372            sb.append(' ');
    373       try {
    374         String ts = obj.toString();
    375         int length = -1;
    376         LispObject stringLength = _JAVA_OBJECT_TO_STRING_LENGTH.symbolValueNoThrow();
    377         if (stringLength instanceof Fixnum) {
    378           length = Fixnum.getValue(stringLength);
    379         }
    380         if (length < 0) {
    381           sb.append(ts);
    382         } else if (ts.length() > length) {
    383           // use '....' to not confuse user with PPRINT conventions
    384           sb.append(ts.substring(0, length)).append("....");
    385         } else {
    386           sb.append(ts);
    387         }
    388         s = sb.toString();
    389       } catch (Exception e) {
    390         return serror(new JavaException(e));
    391       }
     373                        try {
     374                                String ts = obj.toString();
     375                                int length = -1;
     376                                LispObject stringLength = _JAVA_OBJECT_TO_STRING_LENGTH.symbolValueNoThrow();
     377                                if (stringLength instanceof Fixnum) {
     378                                        length = Fixnum.getValue(stringLength);
     379                                }
     380                                if (length < 0) {
     381                                        sb.append(ts);
     382                                } else if (ts.length() > length) {
     383                                        // use '....' to not confuse user with PPRINT conventions
     384                                        sb.append(ts.substring(0, length)).append("....");
     385                                } else {
     386                                        sb.append(ts);
     387                                }
     388                                s = sb.toString();
     389                        } catch (Exception e) {
     390                                return serror(new JavaException(e));
     391                        }
    392392        } else {
    393393            s = "null";
    … …  
    414414                for (int i = 0; i < length; i++) {
    415415                    parts = parts
    416           .push(new Cons(new SimpleString(String.valueOf(i)),
     416                      .push(new Cons(new SimpleString(String.valueOf(i)),
    417417                                       JavaObject.getInstance(Array.get(obj, i))));
    418418                }
    … …  
    609609    = new pf_describe_java_object();
    610610  @DocString(name="describe-java-object",
    611        args="object stream",
    612        doc="Print a human friendly description of Java OBJECT to STREAM.")
     611             args="object stream",
     612             doc="Print a human friendly description of Java OBJECT to STREAM.")
    613613  private static final class pf_describe_java_object extends Primitive
    614614  {
    … …  
    619619    public LispObject execute(LispObject first, LispObject second) {
    620620      if (!(first instanceof JavaObject))
    621   return type_error(first, Symbol.JAVA_OBJECT);
     621        return type_error(first, Symbol.JAVA_OBJECT);
    622622      final Stream stream = checkStream(second);
    623623      final JavaObject javaObject = (JavaObject) first;

  • trunk/abcl/src/org/armedbear/lisp/JavaStackFrame.java

    r14953 r15569  
    6161    final String JAVA_STACK_FRAME = "JAVA-STACK-FRAME";
    6262    return unreadableString(JAVA_STACK_FRAME + " "
    63         + toLispString().toString());
     63                                + toLispString().toString());
    6464  }
    6565
    … …  
    122122    LispObject result = NIL;
    123123    result = result.push(new Cons("CLASS",
    124           new SimpleString(javaFrame.getClassName())));
     124                                  new SimpleString(javaFrame.getClassName())));
    125125    result = result.push(new Cons("METHOD",
    126           new SimpleString(javaFrame.getMethodName())));
     126                                  new SimpleString(javaFrame.getMethodName())));
    127127    result = result.push(new Cons("FILE",
    128           new SimpleString(javaFrame.getFileName())));
     128                                  new SimpleString(javaFrame.getFileName())));
    129129    result = result.push(new Cons("LINE",
    130           Fixnum.getInstance(javaFrame.getLineNumber())));
     130                                  Fixnum.getInstance(javaFrame.getLineNumber())));
    131131    result = result.push(new Cons("NATIVE-METHOD",
    132           LispObject.getInstance(javaFrame.isNativeMethod())));
     132                                  LispObject.getInstance(javaFrame.isNativeMethod())));
    133133    return result.nreverse();
    134134  }

  • trunk/abcl/src/org/armedbear/lisp/LispCharacter.java

    r15228 r15569  
    270270            sb.append("No-break_space");
    271271            break;
    272     default:
    273       if (name!=null)
     272          default:
     273            if (name!=null)
    274274              sb.append(name);
    275       else
     275            else
    276276              sb.append(value);
    277277            break;

  • trunk/abcl/src/org/armedbear/lisp/LispObject.java

    r15027 r15569  
    137137
    138138    return error(new LispError("The value " + princToString() +
    139         " is not of class " + c.getName()));
     139                                " is not of class " + c.getName()));
    140140  }
    141141

  • trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java

    r15552 r15569  
    106106      LispObject lambdaName = ((Operator)operator).getLambdaName();
    107107      if (lambdaName != null && lambdaName != Lisp.NIL)
    108   return result.push(lambdaName);
     108        return result.push(lambdaName);
    109109    }
    110110    return result.push(operator);
    … …  
    161161      result = result.push(new Cons("ARGS", args));
    162162    }
    163      
     163                       
    164164    return result.nreverse();
    165165  }

  • trunk/abcl/src/org/armedbear/lisp/Load.java

    r15458 r15569  
    206206          truename = (Pathname)initTruename;
    207207        }
    208        
     208                               
    209209        InputStream in = truename.getInputStream();
    210210        Debug.assertTrue(in != null);
    … …  
    370370            final SpecialBindingsMark mark = thread.markSpecialBindings();
    371371            thread.bindSpecial(_WARN_ON_REDEFINITION_, NIL);
    372       thread.bindSpecial(FASL_LOADER, NIL);
     372            thread.bindSpecial(FASL_LOADER, NIL);
    373373            try {
    374374                Stream stream = new Stream(Symbol.SYSTEM_STREAM, in, Symbol.CHARACTER);
    … …  
    636636                if (obj == EOF)
    637637                    break;
    638     result = eval(obj, env, thread);
     638                result = eval(obj, env, thread);
    639639                if (print) {
    640640                    Stream out =

  • trunk/abcl/src/org/armedbear/lisp/Package.java

    r15036 r15569  
    929929
    930930    public Object readResolve() throws java.io.ObjectStreamException {
    931   Package pkg = findPackage(name);
    932   if(pkg != null) {
    933       return pkg;
    934   } else {
    935       return error(new PackageError(name + " is not the name of a package.", new SimpleString(name)));
    936   }
     931        Package pkg = findPackage(name);
     932        if(pkg != null) {
     933            return pkg;
     934        } else {
     935            return error(new PackageError(name + " is not the name of a package.", new SimpleString(name)));
     936        }
    937937    }
    938938}

  • trunk/abcl/src/org/armedbear/lisp/Pathname.java

    r15492 r15569  
    17471747        } else {
    17481748          if (d instanceof JarPathname
    1749         && p instanceof JarPathname) {
     1749              && p instanceof JarPathname) {
    17501750            result.setDevice(d.getDevice());
    17511751          } else {
    … …  
    17671767          }
    17681768        } else {
    1769     if (p.isLocalFile()) {
    1770       result.setDevice(d.getDevice());
    1771     } else {
    1772       result.setDevice(p.getDevice());
    1773     }
     1769          if (p.isLocalFile()) {
     1770            result.setDevice(d.getDevice());
     1771          } else {
     1772            result.setDevice(p.getDevice());
     1773          }
    17741774        }
    17751775      }

  • trunk/abcl/src/org/armedbear/lisp/ProgramError.java

    r15001 r15569  
    5151           setFormatControl(initArgs.car().getStringValue());
    5252           setFormatArguments(initArgs.cdr());
    53   }
     53        }
    5454
    5555    }

  • trunk/abcl/src/org/armedbear/lisp/Ratio.java

    r15548 r15569  
    526526            return new DoubleFloat(doubleValue()).truncate(obj);
    527527        BigInteger n, d;
    528   try {
    529     if (obj instanceof Fixnum) {
     528        try {
     529          if (obj instanceof Fixnum) {
    530530            n = ((Fixnum)obj).getBigInteger();
    531531            d = BigInteger.ONE;
    532     } else if (obj instanceof Bignum) {
     532          } else if (obj instanceof Bignum) {
    533533            n = ((Bignum)obj).value;
    534534            d = BigInteger.ONE;
    535     } else if (obj instanceof Ratio) {
     535          } else if (obj instanceof Ratio) {
    536536            n = ((Ratio)obj).numerator();
    537537            d = ((Ratio)obj).denominator();
    538     } else {
     538          } else {
    539539            return type_error(obj, Symbol.NUMBER);
    540     }
    541     // Invert and multiply.
    542     BigInteger num = numerator.multiply(d);
    543     BigInteger den = denominator.multiply(n);
    544     BigInteger quotient = num.divide(den);
    545     // Multiply quotient by divisor.
    546     LispObject product = number(quotient.multiply(n), d);
    547     // Subtract to get remainder.
    548     LispObject remainder = subtract(product);
     540          }
     541          // Invert and multiply.
     542          BigInteger num = numerator.multiply(d);
     543          BigInteger den = denominator.multiply(n);
     544          BigInteger quotient = num.divide(den);
     545          // Multiply quotient by divisor.
     546          LispObject product = number(quotient.multiply(n), d);
     547          // Subtract to get remainder.
     548          LispObject remainder = subtract(product);
    549549          return LispThread.currentThread().setValues(number(quotient), remainder);
    550550        }

  • trunk/abcl/src/org/armedbear/lisp/Readtable.java

    r14448 r15569  
    310310  protected static class DispatchTable
    311311  {
    312   protected final CharHashMap<LispObject> functions;
     312        protected final CharHashMap<LispObject> functions;
    313313
    314314    public DispatchTable()
    … …  
    535535        toReadtable.syntax.put(toChar, fromReadtable.syntax.get(fromChar));
    536536        toReadtable.readerMacroFunctions.put(toChar,
    537             fromReadtable.readerMacroFunctions.get(fromChar));
     537                        fromReadtable.readerMacroFunctions.get(fromChar));
    538538        // "If the character is a dispatching macro character, its entire
    539539        // dispatch table of reader macro functions is copied."
    540540        DispatchTable found = fromReadtable.dispatchTables.get(fromChar);
    541541        if (found!=null)
    542           toReadtable.dispatchTables.put(toChar, new DispatchTable(found));         
     542                toReadtable.dispatchTables.put(toChar, new DispatchTable(found));         
    543543        else
    544544            // Don't leave behind dispatch tables when fromChar
    545545            // doesn't have one
    546           toReadtable.dispatchTables.put(toChar, null);
     546                toReadtable.dispatchTables.put(toChar, null);
    547547        return T;
    548548      }

  • trunk/abcl/src/org/armedbear/lisp/RuntimeClass.java

    r12513 r15569  
    5757            if (length < 3 || length % 2 != 1)
    5858                return error(new WrongNumberOfArgumentsException(this));
    59         RuntimeClass rc = new RuntimeClass();
    60         String className = args[0].getStringValue();
     59              RuntimeClass rc = new RuntimeClass();
     60              String className = args[0].getStringValue();
    6161            for (int i = 1; i < length; i = i+2) {
    6262                String methodName = args[i].getStringValue();
    6363                rc.addLispMethod(methodName, (Function)args[i+1]);
    64         }
     64              }
    6565            classes.put(className, rc);
    66         return T;
     66              return T;
    6767        }
    6868    };
    … …  
    8080        {
    8181
    82       String cn = className.getStringValue();
    83       String mn = methodName.getStringValue();
    84       Function def = (Function) methodDef;
    85       RuntimeClass rc = null;
    86       if (classes.containsKey(cn)) {
     82            String cn = className.getStringValue();
     83            String mn = methodName.getStringValue();
     84            Function def = (Function) methodDef;
     85            RuntimeClass rc = null;
     86            if (classes.containsKey(cn)) {
    8787                rc = (RuntimeClass) classes.get(cn);
    8888                rc.addLispMethod(mn, def);
    8989                return T;
    90       }
    91       else {
     90            }
     91            else {
    9292                error(new LispError("undefined Java class: " + cn));
    9393                return NIL;
    94       }
     94            }
    9595        }
    9696    };
    … …  
    106106        {
    107107            String cn = className.getStringValue();
    108         String pn = cn.substring(0,cn.lastIndexOf('.'));
    109         byte[] cb = (byte[]) classBytes.javaInstance();
     108              String pn = cn.substring(0,cn.lastIndexOf('.'));
     109              byte[] cb = (byte[]) classBytes.javaInstance();
    110110            try {
    111111                JavaClassLoader loader = JavaClassLoader.getPersistentInstance(pn);

  • trunk/abcl/src/org/armedbear/lisp/SocketStream.java

    r13442 r15569  
    4444    public SocketStream(Socket socket, Stream in, Stream out)
    4545    {
    46   super(in, out);
     46        super(in, out);
    4747        this.socket = socket;
    4848    }
    … …  
    7373    public LispObject close(LispObject abort)
    7474    {
    75   try {
    76       socket.close();
    77       setOpen(false);
    78       return T;
    79   } catch (Exception e) {
    80       return error(new LispError(e.getMessage()));
    81   }
     75        try {
     76            socket.close();
     77            setOpen(false);
     78            return T;
     79        } catch (Exception e) {
     80            return error(new LispError(e.getMessage()));
     81        }
    8282    }
    8383}

  • trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java

    r15554 r15569  
    126126        final LispThread thread = LispThread.currentThread();
    127127        final SpecialBindingsMark mark = thread.markSpecialBindings();
    128   Environment ext = new Environment(env);
    129   thread.envStack.push(ext);
     128        Environment ext = new Environment(env);
     129        thread.envStack.push(ext);
    130130        try {
    131131            LispObject varList = checkList(args.car());
    … …  
    152152                if (sequential) {
    153153                    ext = new Environment(ext);
    154         thread.envStack.push(ext);
     154                    thread.envStack.push(ext);
    155155                    bindArg(specials, symbol, value, ext, thread);
    156156                } else
    … …  
    173173        finally {
    174174            thread.resetSpecialBindings(mark);
    175       while (thread.envStack.pop() != ext) {};
     175            while (thread.envStack.pop() != ext) {};
    176176        }
    177177    }
    … …  
    260260            final Environment ext = new Environment(env);
    261261            try {
    262           thread.envStack.push(ext);
    263     args = ext.processDeclarations(args);
    264     return progn(args, ext, thread);
    265       }
    266       finally {
     262                thread.envStack.push(ext);
     263                args = ext.processDeclarations(args);
     264                return progn(args, ext, thread);
     265            }
     266            finally {
    267267              while (thread.envStack.pop() != ext) {};
    268268            }

  • trunk/abcl/src/org/armedbear/lisp/StructureObject.java

    r15025 r15569  
    155155
    156156    protected int getSlotIndex(LispObject slotName) {
    157   LispObject effectiveSlots = structureClass.getSlotDefinitions();
    158   LispObject[] effectiveSlotsArray = effectiveSlots.copyToArray();
    159   for (int i = 0; i < slots.length; i++) {
    160       SimpleVector slotDefinition = (SimpleVector) effectiveSlotsArray[i];
    161       LispObject candidateSlotName = slotDefinition.AREF(1);
    162       if(slotName == candidateSlotName) {
    163     return i;
    164       }
    165   }
    166   return -1;
     157        LispObject effectiveSlots = structureClass.getSlotDefinitions();
     158        LispObject[] effectiveSlotsArray = effectiveSlots.copyToArray();
     159        for (int i = 0; i < slots.length; i++) {
     160            SimpleVector slotDefinition = (SimpleVector) effectiveSlotsArray[i];
     161            LispObject candidateSlotName = slotDefinition.AREF(1);
     162            if(slotName == candidateSlotName) {
     163                return i;
     164            }
     165        }
     166        return -1;
    167167    }
    168168
    … …  
    175175        value = slots[index];
    176176    } else {
    177   value = UNBOUND_VALUE;
     177        value = UNBOUND_VALUE;
    178178        value = Symbol.SLOT_UNBOUND.execute(structureClass, this, slotName);
    179179        LispThread.currentThread()._values = null;
    … …  
    185185      final int index = getSlotIndex(slotName);
    186186      if (index >= 0) {
    187     slots[index] = newValue;
     187          slots[index] = newValue;
    188188      } else {
    189     LispObject[] args = new LispObject[5];
    190     args[0] = structureClass;
    191     args[1] = this;
    192     args[2] = slotName;
    193     args[3] = Symbol.SETF;
    194     args[4] = newValue;
    195     Symbol.SLOT_MISSING.execute(args);
     189          LispObject[] args = new LispObject[5];
     190          args[0] = structureClass;
     191          args[1] = this;
     192          args[2] = slotName;
     193          args[3] = Symbol.SETF;
     194          args[4] = newValue;
     195          Symbol.SLOT_MISSING.execute(args);
    196196      }
    197197  }

  • trunk/abcl/src/org/armedbear/lisp/Symbol.java

    r15542 r15569  
    939939
    940940    public Object readResolve() throws java.io.ObjectStreamException {
    941   if(pkg instanceof Package) {
    942       Symbol s = ((Package) pkg).intern(name.getStringValue());
    943       return s;
    944   } else {
    945       return this;
    946   }
     941        if(pkg instanceof Package) {
     942            Symbol s = ((Package) pkg).intern(name.getStringValue());
     943            return s;
     944        } else {
     945            return this;
     946        }
    947947    }
    948948

  • trunk/abcl/src/org/armedbear/lisp/URLPathname.java

    r15456 r15569  
    109109      } catch (URISyntaxException ex) {
    110110        parse_error("Improper URI syntax for "
    111         + "'" + url.toString() + "'"
    112         + ": " + ex.toString());
    113   return (URLPathname)UNREACHED;
     111                    + "'" + url.toString() + "'"
     112                    + ": " + ex.toString());
     113        return (URLPathname)UNREACHED;
    114114      }
    115115           
    … …  
    121121        if (uriPath == null || uriPath.equals("")) {
    122122          parse_error("The namestring URI has no path: " + uri);
    123     return (URLPathname)UNREACHED;
     123          return (URLPathname)UNREACHED;
    124124        }
    125125      }
    … …  
    146146    } catch (URISyntaxException e) {
    147147      parse_error("Couldn't form URI from "
    148       + "'" + url + "'"
    149       + " because: " + e);
     148                  + "'" + url + "'"
     149                  + " because: " + e);
    150150      return (URLPathname)UNREACHED;
    151151    }
    … …  
    263263    // <https://docs.microsoft.com/en-us/archive/blogs/ie/file-uris-in-windows>
    264264    if (Utilities.isPlatformWindows
    265   && getDevice() instanceof SimpleString) {
     265        && getDevice() instanceof SimpleString) {
    266266      sb.append("/")
    267267        .append(getDevice().getStringValue())
    268   .append(":");
     268        .append(":");
    269269    }
    270270    String directoryNamestring = getDirectoryNamestring();
    … …  
    330330    if (!directory.equals("")) {
    331331      if (Utilities.isPlatformWindows
    332     && getDevice() instanceof SimpleString) {
    333   path = getDevice().getStringValue() + ":" + directory + file;
     332          && getDevice() instanceof SimpleString) {
     333        path = getDevice().getStringValue() + ":" + directory + file;
    334334      } else {
    335   path = directory + file;
     335        path = directory + file;
    336336      }
    337337    } else {

  • trunk/abcl/src/org/armedbear/lisp/WeakReference.java

    r13440 r15569  
    8383        @Override
    8484        public LispObject execute(LispObject obj) {
    85       return new WeakReference(obj);
     85            return new WeakReference(obj);
    8686        }
    8787    };
    … …  
    106106           
    107107            LispObject value = ((WeakReference)obj).ref.get();
    108       return LispThread.currentThread().setValues(value == null ? NIL : value,
     108            return LispThread.currentThread().setValues(value == null ? NIL : value,
    109109                                                        value == null ? NIL : T);
    110110        }

  • trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java

    r15001 r15569  
    5454        super(StandardClass.PROGRAM_ERROR);
    5555        this.operator = operator;
    56   this.expectedMinArgs = expectedMin;
    57   this.expectedMaxArgs = expectedMax;
     56        this.expectedMinArgs = expectedMin;
     57        this.expectedMaxArgs = expectedMax;
    5858        this.actualArgs = args;
    5959        setFormatControl(getMessage().replaceAll("~","~~"));
    … …  
    7777    public WrongNumberOfArgumentsException(String message) {
    7878        super(StandardClass.PROGRAM_ERROR);
    79   if(message == null) {
    80       throw new NullPointerException("message can not be null");
    81   }
    82   this.message = message;
     79        if(message == null) {
     80            throw new NullPointerException("message can not be null");
     81        }
     82        this.message = message;
    8383        setFormatControl(getMessage().replaceAll("~","~~"));
    8484        setFormatArguments(NIL);
    … …  
    8888    public String getMessage()
    8989    {
    90   if(message != null) {
    91       return message;
    92   }
     90        if(message != null) {
     91            return message;
     92        }
    9393        StringBuilder sb =
    9494            new StringBuilder("Wrong number of arguments for "
    9595                              + operator.princToString());
    96   if(expectedMinArgs >= 0 || expectedMaxArgs >= 0) {
    97       sb.append("; ");
     96        if(expectedMinArgs >= 0 || expectedMaxArgs >= 0) {
     97            sb.append("; ");
    9898           
    9999            if (expectedMinArgs == expectedMaxArgs) {
    … …  
    110110            }
    111111           
    112       sb.append(" expected");
    113   }
     112            sb.append(" expected");
     113        }
    114114        if (actualArgs != null) {
    115115            sb.append(" -- provided: ");

  • trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp

    r15503 r15569  
    6161(defun flatten (list)
    6262  (labels ((rflatten (list accumluator)
    63      (dolist (element list)
    64        (if (listp element)
    65     (setf accumluator (rflatten element accumluator))
    66     (push element accumluator)))
    67      accumluator))
     63           (dolist (element list)
     64             (if (listp element)
     65                (setf accumluator (rflatten element accumluator))
     66                (push element accumluator)))
     67           accumluator))
    6868    (let (result)
    6969      (reverse (rflatten list result)))))
    … …  
    7272  "Return a list of the directories as pathnames referenced in the JVM classpath."
    7373  (let* ((separator (java:jstatic "getProperty" "java.lang.System" "path.separator"))
    74   (paths (coerce (java:jcall "split"
    75          (java:jstatic "getProperty" "java.lang.System"
    76           "java.class.path")
    77          separator)
     74        (paths (coerce (java:jcall "split"
     75                           (java:jstatic "getProperty" "java.lang.System"
     76                                        "java.class.path")
     77                           separator)
    7878                        'list))
    7979         (p (coerce paths 'list)))
    … …  
    9292        (cond
    9393          ((java:jinstance-of-p entry "java.net.URLClassLoader") ;; java1.[678]
    94      (dolist (url (coerce (java:jcall "getURLs" entry)
    95               'list))
     94           (dolist (url (coerce (java:jcall "getURLs" entry)
     95                                'list))
    9696             (let ((p (directory-of (pathname (java:jcall "toString" url)))))
    97          (when (probe-file p)
    98            (pushnew p result :test 'equal)))))
     97               (when (probe-file p)
     98                 (pushnew p result :test 'equal)))))
    9999        ((pathnamep entry)
    100100         (pushnew (directory-of entry) result :test 'equal))
    101101        ((and (stringp entry)
    102         (probe-file (pathname (directory-of entry))))
     102              (probe-file (pathname (directory-of entry))))
    103103         (pushnew (pathname (directory-of entry)) result :test 'equal))
    104104        (t
    … …  
    112112  (dolist (d (enumerate-resource-directories))
    113113    (let ((entries (directory (make-pathname :defaults d
    114                :name "*"
    115                :type "jar"))))
     114                                             :name "*"
     115                                             :type "jar"))))
    116116      (let ((jar (some predicate entries)))
    117   (when (and jar (probe-file jar))
    118     (return-from find-jar
     117        (when (and jar (probe-file jar))
     118          (return-from find-jar
    119119            (make-pathname :device (list (probe-file jar)))))))))
    120120

  • trunk/abcl/src/org/armedbear/lisp/adjoin.lisp

    r11695 r15569  
    3636    (error "test and test-not both supplied"))
    3737  (if (let ((key-val (sys::apply-key key item)))
    38   (if notp
    39       (member key-val list :test-not test-not :key key)
    40       (member key-val list :test test :key key)))
     38        (if notp
     39            (member key-val list :test-not test-not :key key)
     40            (member key-val list :test test :key key)))
    4141      list
    4242      (cons item list)))

  • trunk/abcl/src/org/armedbear/lisp/and.lisp

    r11391 r15569  
    3636(defmacro and (&rest forms)
    3737  (cond ((endp forms) t)
    38   ((endp (rest forms)) (first forms))
    39   (t
    40   `(if ,(first forms)
    41         (and ,@(rest forms))
    42         nil))))
     38        ((endp (rest forms)) (first forms))
     39        (t
     40        `(if ,(first forms)
     41              (and ,@(rest forms))
     42              nil))))

  • trunk/abcl/src/org/armedbear/lisp/arrays.lisp

    r15307 r15569  
    6969(defun sbit (simple-bit-array &rest subscripts)
    7070  (row-major-aref simple-bit-array
    71       (%array-row-major-index simple-bit-array subscripts)))
     71                  (%array-row-major-index simple-bit-array subscripts)))
    7272
    7373(defsetf row-major-aref aset)

  • trunk/abcl/src/org/armedbear/lisp/assert.lisp

    r11391 r15569  
    4343     ,@(mapcar #'(lambda (place)
    4444                  `(setf ,place (assert-prompt ',place ,place)))
    45          places)))
     45               places)))
    4646
    4747(defun assert-error (assertion places datum &rest arguments)
    … …  
    6262(defun assert-prompt (name value)
    6363  (cond ((y-or-n-p "The old value of ~S is ~S.~%Do you want to supply a new value? "
    64        name value)
     64                   name value)
    6565         (fresh-line *query-io*)
    66   (format *query-io* "Type a form to be evaluated:~%")
    67   (flet ((read-it () (eval (read *query-io*))))
    68      (if (symbolp name) ;help user debug lexical variables
    69          (progv (list name) (list value) (read-it))
    70          (read-it))))
    71   (t value)))
     66        (format *query-io* "Type a form to be evaluated:~%")
     67        (flet ((read-it () (eval (read *query-io*))))
     68           (if (symbolp name) ;help user debug lexical variables
     69               (progv (list name) (list value) (read-it))
     70               (read-it))))
     71        (t value)))

  • trunk/abcl/src/org/armedbear/lisp/assoc.lisp

    r11391 r15569  
    3838       ((endp alist))
    3939     (if (car alist)
    40   (if ,test-guy (return (car alist))))))
     40        (if ,test-guy (return (car alist))))))
    4141
    4242(defun assoc (item alist &key key test test-not)
    4343  (cond (test
    44   (if key
    45        (assoc-guts (funcall test item (funcall key (caar alist))))
    46        (assoc-guts (funcall test item (caar alist)))))
    47   (test-not
    48   (if key
    49        (assoc-guts (not (funcall test-not item
    50                (funcall key (caar alist)))))
    51        (assoc-guts (not (funcall test-not item (caar alist))))))
    52   (t
    53   (if key
    54        (assoc-guts (eql item (funcall key (caar alist))))
    55        (assoc-guts (eql item (caar alist)))))))
     44        (if key
     45             (assoc-guts (funcall test item (funcall key (caar alist))))
     46             (assoc-guts (funcall test item (caar alist)))))
     47        (test-not
     48        (if key
     49             (assoc-guts (not (funcall test-not item
     50                                       (funcall key (caar alist)))))
     51             (assoc-guts (not (funcall test-not item (caar alist))))))
     52        (t
     53        (if key
     54             (assoc-guts (eql item (funcall key (caar alist))))
     55             (assoc-guts (eql item (caar alist)))))))
    5656
    5757(defun assoc-if (predicate alist &key key)
    … …  
    6767(defun rassoc (item alist &key key test test-not)
    6868  (cond (test
    69   (if key
    70        (assoc-guts (funcall test item (funcall key (cdar alist))))
    71        (assoc-guts (funcall test item (cdar alist)))))
    72   (test-not
    73   (if key
    74        (assoc-guts (not (funcall test-not item
    75                (funcall key (cdar alist)))))
    76        (assoc-guts (not (funcall test-not item (cdar alist))))))
    77   (t
    78   (if key
    79        (assoc-guts (eql item (funcall key (cdar alist))))
    80        (assoc-guts (eql item (cdar alist)))))))
     69        (if key
     70             (assoc-guts (funcall test item (funcall key (cdar alist))))
     71             (assoc-guts (funcall test item (cdar alist)))))
     72        (test-not
     73        (if key
     74             (assoc-guts (not (funcall test-not item
     75                                       (funcall key (cdar alist)))))
     76             (assoc-guts (not (funcall test-not item (cdar alist))))))
     77        (t
     78        (if key
     79             (assoc-guts (eql item (funcall key (cdar alist))))
     80             (assoc-guts (eql item (cdar alist)))))))
    8181
    8282(defun rassoc-if (predicate alist &key key)
    … …  
    9898      ((and (endp x) (endp y)) alist)
    9999    (if (or (endp x) (endp y))
    100   (error "the lists of keys and data are of unequal length"))
     100        (error "the lists of keys and data are of unequal length"))
    101101    (setq alist (acons (car x) (car y) alist))))
    102102
    … …  
    107107      alist
    108108      (let ((result
    109        (cons (if (atom (car alist))
    110            (car alist)
    111            (cons (caar alist) (cdar alist)))
    112        nil)))
    113   (do ((x (cdr alist) (cdr x))
    114        (splice result
    115          (cdr (rplacd splice
    116           (cons
    117            (if (atom (car x))
    118                (car x)
    119                (cons (caar x) (cdar x)))
    120            nil)))))
    121       ((endp x)))
    122   result)))
     109             (cons (if (atom (car alist))
     110                       (car alist)
     111                       (cons (caar alist) (cdar alist)))
     112                   nil)))
     113        (do ((x (cdr alist) (cdr x))
     114             (splice result
     115                     (cdr (rplacd splice
     116                                  (cons
     117                                   (if (atom (car x))
     118                                       (car x)
     119                                       (cons (caar x) (cdar x)))
     120                                   nil)))))
     121            ((endp x)))
     122        result)))

  • trunk/abcl/src/org/armedbear/lisp/backquote.lisp

    r14591 r15569  
    4848;;;
    4949;;;   |`,|: [a] => a
    50 ;;;    NIL: [a] => a    ;the NIL flag is used only when a is NIL
    51 ;;;      T: [a] => a    ;the T flag is used when a is self-evaluating
     50;;;    NIL: [a] => a            ;the NIL flag is used only when a is NIL
     51;;;      T: [a] => a            ;the T flag is used when a is self-evaluating
    5252;;;  QUOTE: [a] => (QUOTE a)
    5353;;; APPEND: [a] => (APPEND . a)
    … …  
    8484  (let ((*backquote-count* (1+ *backquote-count*)))
    8585    (multiple-value-bind (flag thing)
    86   (backquotify stream (read stream t nil t))
     86        (backquotify stream (read stream t nil t))
    8787      (when (eq flag *bq-at-flag*)
    88   (%reader-error stream ",@ after backquote in ~S" thing))
     88        (%reader-error stream ",@ after backquote in ~S" thing))
    8989      (when (eq flag *bq-dot-flag*)
    90   (%reader-error stream ",. after backquote in ~S" thing))
     90        (%reader-error stream ",. after backquote in ~S" thing))
    9191      (backquotify-1 flag thing))))
    9292
    … …  
    9898    (%reader-error stream "Comma not inside a backquote."))
    9999  (let ((c (read-char stream))
    100   (*backquote-count* (1- *backquote-count*)))
     100        (*backquote-count* (1- *backquote-count*)))
    101101    (cond ((char= c #\@)
    102      (cons *bq-at-flag* (read stream t nil t)))
    103     ((char= c #\.)
    104      (cons *bq-dot-flag* (read stream t nil t)))
    105     (t (unread-char c stream)
    106        (cons *bq-comma-flag* (read stream t nil t))))))
     102           (cons *bq-at-flag* (read stream t nil t)))
     103          ((char= c #\.)
     104           (cons *bq-dot-flag* (read stream t nil t)))
     105          (t (unread-char c stream)
     106             (cons *bq-comma-flag* (read stream t nil t))))))
    107107
    108108;;;
    … …  
    116116(defun backquotify (stream code)
    117117  (cond ((atom code)
    118   (cond ((null code) (values nil nil))
    119          ((or (consp code)
     118        (cond ((null code) (values nil nil))
     119               ((or (consp code)
    120120                    (symbolp code))
    121     ;; Keywords are self-evaluating. Install after packages.
     121                ;; Keywords are self-evaluating. Install after packages.
    122122                (values 'quote code))
    123          (t (values t code))))
    124   ((or (eq (car code) *bq-at-flag*)
    125        (eq (car code) *bq-dot-flag*))
    126   (values (car code) (cdr code)))
    127   ((eq (car code) *bq-comma-flag*)
    128   (comma (cdr code)))
    129   ((eq (car code) *bq-vector-flag*)
    130   (multiple-value-bind (dflag d) (backquotify stream (cdr code))
    131      (values 'vector (backquotify-1 dflag d))))
    132   (t (multiple-value-bind (aflag a) (backquotify stream (car code))
    133        (multiple-value-bind (dflag d) (backquotify stream (cdr code))
    134          (when (eq dflag *bq-at-flag*)
    135     ;; Get the errors later.
    136     (%reader-error stream ",@ after dot in ~S" code))
    137          (when (eq dflag *bq-dot-flag*)
    138     (%reader-error stream ",. after dot in ~S" code))
    139          (cond
    140     ((eq aflag *bq-at-flag*)
    141     (if (null dflag)
    142          (if (expandable-backq-expression-p a)
     123               (t (values t code))))
     124        ((or (eq (car code) *bq-at-flag*)
     125             (eq (car code) *bq-dot-flag*))
     126        (values (car code) (cdr code)))
     127        ((eq (car code) *bq-comma-flag*)
     128        (comma (cdr code)))
     129        ((eq (car code) *bq-vector-flag*)
     130        (multiple-value-bind (dflag d) (backquotify stream (cdr code))
     131           (values 'vector (backquotify-1 dflag d))))
     132        (t (multiple-value-bind (aflag a) (backquotify stream (car code))
     133             (multiple-value-bind (dflag d) (backquotify stream (cdr code))
     134               (when (eq dflag *bq-at-flag*)
     135                ;; Get the errors later.
     136                (%reader-error stream ",@ after dot in ~S" code))
     137               (when (eq dflag *bq-dot-flag*)
     138                (%reader-error stream ",. after dot in ~S" code))
     139               (cond
     140                ((eq aflag *bq-at-flag*)
     141                (if (null dflag)
     142                     (if (expandable-backq-expression-p a)
    143143                         (values 'append (list a))
    144144                         (comma a))
    145          (values 'append
    146            (cond ((eq dflag 'append)
    147             (cons a d ))
    148            (t (list a (backquotify-1 dflag d)))))))
    149     ((eq aflag *bq-dot-flag*)
    150     (if (null dflag)
    151          (if (expandable-backq-expression-p a)
     145                     (values 'append
     146                             (cond ((eq dflag 'append)
     147                                    (cons a d ))
     148                                   (t (list a (backquotify-1 dflag d)))))))
     149                ((eq aflag *bq-dot-flag*)
     150                (if (null dflag)
     151                     (if (expandable-backq-expression-p a)
    152152                         (values 'nconc (list a))
    153153                         (comma a))
    154          (values 'nconc
    155            (cond ((eq dflag 'nconc)
    156             (cons a d))
    157            (t (list a (backquotify-1 dflag d)))))))
    158     ((null dflag)
    159     (if (memq aflag '(quote t nil))
    160          (values 'quote (list a))
    161          (values 'list (list (backquotify-1 aflag a)))))
    162     ((memq dflag '(quote t))
    163     (if (memq aflag '(quote t nil))
    164          (values 'quote (cons a d ))
    165          (values 'list* (list (backquotify-1 aflag a)
    166             (backquotify-1 dflag d)))))
    167     (t (setq a (backquotify-1 aflag a))
    168        (if (memq dflag '(list list*))
    169            (values dflag (cons a d))
    170            (values 'list*
    171              (list a (backquotify-1 dflag d)))))))))))
     154                     (values 'nconc
     155                             (cond ((eq dflag 'nconc)
     156                                    (cons a d))
     157                                   (t (list a (backquotify-1 dflag d)))))))
     158                ((null dflag)
     159                (if (memq aflag '(quote t nil))
     160                     (values 'quote (list a))
     161                     (values 'list (list (backquotify-1 aflag a)))))
     162                ((memq dflag '(quote t))
     163                (if (memq aflag '(quote t nil))
     164                     (values 'quote (cons a d ))
     165                     (values 'list* (list (backquotify-1 aflag a)
     166                                          (backquotify-1 dflag d)))))
     167                (t (setq a (backquotify-1 aflag a))
     168                   (if (memq dflag '(list list*))
     169                       (values dflag (cons a d))
     170                       (values 'list*
     171                               (list a (backquotify-1 dflag d)))))))))))
    172172
    173173;;; This handles the <hair> cases.
    174174(defun comma (code)
    175175  (cond ((atom code)
    176   (cond ((null code)
    177     (values nil nil))
    178          ((or (numberp code) (eq code t))
    179     (values t code))
    180          (t (values *bq-comma-flag* code))))
    181   ((and (eq (car code) 'quote)
     176        (cond ((null code)
     177                (values nil nil))
     178               ((or (numberp code) (eq code t))
     179                (values t code))
     180               (t (values *bq-comma-flag* code))))
     181        ((and (eq (car code) 'quote)
    182182              (not (expandable-backq-expression-p (cadr code))))
    183183         (values (car code) (cadr code)))
    184   ((memq (car code) '(append list list* nconc))
    185   (values (car code) (cdr code)))
    186   ((eq (car code) 'cons)
    187   (values 'list* (cdr code)))
    188   (t (values *bq-comma-flag* code))))
     184        ((memq (car code) '(append list list* nconc))
     185        (values (car code) (cdr code)))
     186        ((eq (car code) 'cons)
     187        (values 'list* (cdr code)))
     188        (t (values *bq-comma-flag* code))))
    189189
    190190;;; This handles table 1.
    191191(defun backquotify-1 (flag thing)
    192192  (cond ((or (eq flag *bq-comma-flag*)
    193        (memq flag '(t nil)))
    194   thing)
    195   ((eq flag 'quote)
    196   (list  'quote thing))
    197   ((eq flag 'list*)
     193             (memq flag '(t nil)))
     194        thing)
     195        ((eq flag 'quote)
     196        (list  'quote thing))
     197        ((eq flag 'list*)
    198198         (cond ((and (null (cddr thing))
    199199                     (not (expandable-backq-expression-p (cadr thing))))
    200     (cons 'backq-cons thing))
    201          ((expandable-backq-expression-p (car (last thing)))
     200                (cons 'backq-cons thing))
     201               ((expandable-backq-expression-p (car (last thing)))
    202202                (list 'backq-append
    203203                      (cons 'backq-list (butlast thing))
    … …  
    205205                      (car (last thing))))
    206206               (t
    207     (cons 'backq-list* thing))))
    208   ((eq flag 'vector)
    209   (list 'backq-vector thing))
    210   (t (cons (ecase flag
    211        ((list) 'backq-list)
    212        ((append) 'backq-append)
    213        ((nconc) 'backq-nconc))
    214     thing))))
     207                (cons 'backq-list* thing))))
     208        ((eq flag 'vector)
     209        (list 'backq-vector thing))
     210        (t (cons (ecase flag
     211                   ((list) 'backq-list)
     212                   ((append) 'backq-append)
     213                   ((nconc) 'backq-nconc))
     214                thing))))
    215215
    216216;;;; magic BACKQ- versions of builtin functions
    … …  
    236236(defun %reader-error (stream control &rest args)
    237237  (error 'reader-error
    238   :stream stream
    239   :format-control control
    240   :format-arguments args))
     238        :stream stream
     239        :format-control control
     240        :format-arguments args))

  • trunk/abcl/src/org/armedbear/lisp/bit-array-ops.lisp

    r11391 r15569  
    3737  (declare (type (array bit) array1 array2))
    3838  (and (= (array-rank array1)
    39     (array-rank array2))
     39          (array-rank array2))
    4040       (dotimes (index (array-rank array1) t)
    41   (when (/= (array-dimension array1 index)
    42        (array-dimension array2 index))
    43      (return nil)))))
     41        (when (/= (array-dimension array1 index)
     42                   (array-dimension array2 index))
     43           (return nil)))))
    4444
    4545(defun require-same-dimensions (array1 array2)
    … …  
    5353    ((t) bit-array-1)
    5454    ((nil) (make-array (array-dimensions bit-array-1)
    55            :element-type 'bit
    56            :initial-element 0))
     55                       :element-type 'bit
     56                       :initial-element 0))
    5757    (t
    5858     (require-same-dimensions bit-array-1 result-bit-array)

  • trunk/abcl/src/org/armedbear/lisp/butlast.lisp

    r11391 r15569  
    3939  (unless (null list)
    4040    (let ((length (do ((list list (cdr list))
    41            (i 0 (1+ i)))
     41                       (i 0 (1+ i)))
    4242                      ((atom list) (1- i)))))
    4343      (unless (< length n)
    44   (do* ((top (cdr list) (cdr top))
    45         (result (list (car list)))
    46         (splice result)
    47         (count length (1- count)))
     44        (do* ((top (cdr list) (cdr top))
     45              (result (list (car list)))
     46              (splice result)
     47              (count length (1- count)))
    4848             ((= count n) result)
    49     (setq splice (cdr (rplacd splice (list (car top))))))))))
     49          (setq splice (cdr (rplacd splice (list (car top))))))))))
    5050
    5151(defun nbutlast (list &optional (n 1))
    … …  
    5454  (unless (null list)
    5555    (let ((length (do ((list list (cdr list))
    56            (i 0 (1+ i)))
     56                       (i 0 (1+ i)))
    5757                      ((atom list) (1- i)))))
    5858      (unless (< length n)
    59   (do ((1st (cdr list) (cdr 1st))
    60        (2nd list 1st)
    61        (count length (1- count)))
     59        (do ((1st (cdr list) (cdr 1st))
     60             (2nd list 1st)
     61             (count length (1- count)))
    6262            ((= count n)
    6363             (rplacd 2nd ())

  • trunk/abcl/src/org/armedbear/lisp/case.lisp

    r11391 r15569  
    3838  (or (zerop n) ; since anything can be considered an improper list of length 0
    3939      (and (consp x)
    40      (list-of-length-at-least-p (cdr x) (1- n)))))
     40           (list-of-length-at-least-p (cdr x) (1- n)))))
    4141
    4242(defun case-body-error (name keyform keyform-value expected-type keys)
    … …  
    6666  (if proceedp
    6767      (let ((block (gensym))
    68       (again (gensym)))
    69   `(let ((,keyform-value ,keyform))
    70      (block ,block
    71        (tagbody
    72         ,again
    73         (return-from
    74          ,block
    75          (cond ,@(nreverse clauses)
    76          (t
    77           (setf ,keyform-value
    78           (setf ,keyform
    79           (case-body-error
    80            ',name ',keyform ,keyform-value
    81            ',expected-type ',keys)))
    82           (go ,again))))))))
     68            (again (gensym)))
     69        `(let ((,keyform-value ,keyform))
     70           (block ,block
     71             (tagbody
     72              ,again
     73              (return-from
     74               ,block
     75               (cond ,@(nreverse clauses)
     76                     (t
     77                      (setf ,keyform-value
     78                            (setf ,keyform
     79                                  (case-body-error
     80                                   ',name ',keyform ,keyform-value
     81                                   ',expected-type ',keys)))
     82                      (go ,again))))))))
    8383      `(let ((,keyform-value ,keyform))
    84   (cond
    85     ,@(nreverse clauses)
    86     ,@(if errorp
    87 ;;    `((t (error 'case-failure
    88 ;;          :name ',name
    89 ;;          :datum ,keyform-value
    90 ;;          :expected-type ',expected-type
    91 ;;          :possibilities ',keys))))))))
    92     `((t (error 'type-error
    93           :datum ,keyform-value
    94           :expected-type ',expected-type))))))))
     84        (cond
     85          ,@(nreverse clauses)
     86          ,@(if errorp
     87;;              `((t (error 'case-failure
     88;;                          :name ',name
     89;;                          :datum ,keyform-value
     90;;                          :expected-type ',expected-type
     91;;                          :possibilities ',keys))))))))
     92                `((t (error 'type-error
     93                            :datum ,keyform-value
     94                            :expected-type ',expected-type))))))))
    9595
    9696;;; CASE-BODY returns code for all the standard "case" macros. NAME is
    … …  
    109109    (warn "no clauses in ~S" name))
    110110  (let ((keyform-value (gensym))
    111   (clauses ())
    112   (keys ()))
     111        (clauses ())
     112        (keys ()))
    113113    (do* ((cases cases (cdr cases))
    114     (case (car cases) (car cases)))
    115   ((null cases) nil)
     114          (case (car cases) (car cases)))
     115        ((null cases) nil)
    116116      (unless (list-of-length-at-least-p case 1)
    117   (error "~S -- bad clause in ~S" case name))
     117        (error "~S -- bad clause in ~S" case name))
    118118      (destructuring-bind (keyoid &rest forms) case
    119   (cond ((and (memq keyoid '(t otherwise))
    120         (null (cdr cases)))
    121          (if errorp
    122        (progn
    123          (style-warn "~@<Treating bare ~A in ~A as introducing a ~
     119        (cond ((and (memq keyoid '(t otherwise))
     120                    (null (cdr cases)))
     121               (if errorp
     122                   (progn
     123                     (style-warn "~@<Treating bare ~A in ~A as introducing a ~
    124124                                  normal-clause, not an otherwise-clause~@:>"
    125         keyoid name)
    126          (push keyoid keys)
    127          (push `((,test ,keyform-value ',keyoid) nil ,@forms)
    128          clauses))
    129        (push `(t nil ,@forms) clauses)))
    130         ((and multi-p (listp keyoid))
    131          (setf keys (append keyoid keys))
    132          (push `((or ,@(mapcar (lambda (key)
    133                `(,test ,keyform-value ',key))
    134              keyoid))
    135            nil
    136            ,@forms)
    137          clauses))
    138         (t
    139          (push keyoid keys)
    140          (push `((,test ,keyform-value ',keyoid)
    141            nil
    142            ,@forms)
    143          clauses)))))
     125                                keyoid name)
     126                     (push keyoid keys)
     127                     (push `((,test ,keyform-value ',keyoid) nil ,@forms)
     128                           clauses))
     129                   (push `(t nil ,@forms) clauses)))
     130              ((and multi-p (listp keyoid))
     131               (setf keys (append keyoid keys))
     132               (push `((or ,@(mapcar (lambda (key)
     133                                       `(,test ,keyform-value ',key))
     134                                     keyoid))
     135                       nil
     136                       ,@forms)
     137                     clauses))
     138              (t
     139               (push keyoid keys)
     140               (push `((,test ,keyform-value ',keyoid)
     141                       nil
     142                       ,@forms)
     143                     clauses)))))
    144144    (case-body-aux name keyform keyform-value clauses keys errorp proceedp
    145        `(,(if multi-p 'member 'or) ,@keys))))
     145                   `(,(if multi-p 'member 'or) ,@keys))))
    146146
    147147(defmacro case (keyform &body cases)

  • trunk/abcl/src/org/armedbear/lisp/chars.lisp

    r11391 r15569  
    3636(defun char/= (character &rest more-characters)
    3737  (do* ((head character (car list))
    38   (list more-characters (cdr list)))
     38        (list more-characters (cdr list)))
    3939       ((atom list) T)
    4040    (unless (do* ((l list (cdr l)))                  ;inner loop returns T
    41      ((atom l) T)          ; iff head /= rest.
    42         (if (eql head (car l)) (return nil)))
     41                 ((atom l) T)                        ; iff head /= rest.
     42              (if (eql head (car l)) (return nil)))
    4343      (return nil))))
    4444
    4545(defun char> (character &rest more-characters)
    4646  (do* ((c character (car list))
    47   (list more-characters (cdr list)))
     47        (list more-characters (cdr list)))
    4848       ((atom list) T)
    4949    (unless (> (char-int c)
    50          (char-int (car list)))
     50               (char-int (car list)))
    5151      (return nil))))
    5252
    5353(defun char>= (character &rest more-characters)
    5454  (do* ((c character (car list))
    55   (list more-characters (cdr list)))
     55        (list more-characters (cdr list)))
    5656       ((atom list) T)
    5757    (unless (>= (char-int c)
    58     (char-int (car list)))
     58                (char-int (car list)))
    5959      (return nil))))
    6060
    … …  
    6565(defun char-not-equal (character &rest more-characters)
    6666  (do* ((head character (car list))
    67   (list more-characters (cdr list)))
     67        (list more-characters (cdr list)))
    6868       ((atom list) T)
    6969    (unless (do* ((l list (cdr l)))
    70     ((atom l) T)
    71         (if (= (equal-char-code head)
    72          (equal-char-code (car l)))
    73       (return nil)))
     70                ((atom l) T)
     71              (if (= (equal-char-code head)
     72                     (equal-char-code (car l)))
     73                  (return nil)))
    7474      (return nil))))

  • trunk/abcl/src/org/armedbear/lisp/check-type.lisp

    r11391 r15569  
    5151                                  :format-arguments
    5252                                  (list place place-value type-string))
    53       (make-condition 'simple-type-error
    54           :datum place-value :expected-type type
    55           :format-control
     53                  (make-condition 'simple-type-error
     54                                  :datum place-value :expected-type type
     55                                  :format-control
    5656                                  "The value of ~S is ~S, which is not of type ~S."
    57           :format-arguments
    58           (list place place-value type)))))
     57                                  :format-arguments
     58                                  (list place place-value type)))))
    5959    (restart-case (error cond)
    6060      (store-value (value)

  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r15564 r15569  
    22002200                                  (subseq gf-lambda-list (position '&aux gf-lambda-list)))))))
    22012201    (if gf
    2202   (restart-case
    2203       (check-method-lambda-list name method-lambda-list
    2204               (generic-function-lambda-list gf))
    2205     (unbind-and-try-again () :report (lambda(s) (format s "Undefine generic function #'~a and continue" name))
    2206       (fmakunbound name)
    2207       (setf gf (ensure-generic-function name :lambda-list gf-lambda-list))))
     2202        (restart-case
     2203            (check-method-lambda-list name method-lambda-list
     2204                                      (generic-function-lambda-list gf))
     2205          (unbind-and-try-again () :report (lambda(s) (format s "Undefine generic function #'~a and continue" name))
     2206            (fmakunbound name)
     2207            (setf gf (ensure-generic-function name :lambda-list gf-lambda-list))))
    22082208        (setf gf (ensure-generic-function name :lambda-list gf-lambda-list)))
    22092209    (let ((method
    … …  
    29012901      (setf specializers-form `(list ,@(nreverse specializers-form)))
    29022902      `(progn
    2903   (sys::record-source-information-for-type ',function-name '(:method ,function-name ,qualifiers ,specializers))
     2903        (sys::record-source-information-for-type ',function-name '(:method ,function-name ,qualifiers ,specializers))
    29042904         (ensure-method ',function-name
    29052905                        :lambda-list ',lambda-list
    … …  
    30483048       (sys::record-source-information-for-type ',function-name '(:generic-function ,function-name))
    30493049       ,@(loop for method-form in rest
    3050          when (eq (car method-form) :method)
    3051         collect
    3052         (multiple-value-bind (function-name qualifiers lambda-list specializers documentation declarations body)
    3053       (mop::parse-defmethod `(,function-name ,@(rest method-form)))
    3054           `(sys::record-source-information-for-type ',function-name '(:method ,function-name ,qualifiers ,specializers))))
     3050               when (eq (car method-form) :method)
     3051                    collect
     3052                    (multiple-value-bind (function-name qualifiers lambda-list specializers documentation declarations body)
     3053                        (mop::parse-defmethod `(,function-name ,@(rest method-form)))
     3054                      `(sys::record-source-information-for-type ',function-name '(:method ,function-name ,qualifiers ,specializers))))
    30553055       (let ((gf (symbol-function ',temp-sym)))
    30563056         ;; FIXME (rudi 2012-07-08): fset gets the source location info
    … …  
    33223322    (let ((methods '()))
    33233323      (dolist (method (generic-function-methods gf))
    3324   (multiple-value-bind (applicable knownp)
    3325       (method-applicable-using-classes-p method classes)
    3326     (cond (applicable
    3327     (push method methods))
    3328     ((not knownp)
    3329     (return-from compute-applicable-methods-using-classes
    3330        (values nil nil))))))
     3324        (multiple-value-bind (applicable knownp)
     3325            (method-applicable-using-classes-p method classes)
     3326          (cond (applicable
     3327                (push method methods))
     3328                ((not knownp)
     3329                (return-from compute-applicable-methods-using-classes
     3330                   (values nil nil))))))
    33313331      (values (sort-methods methods gf classes)
    3332         t))))
     3332              t))))
    33333333
    33343334
    … …  
    38073807
    38083808(defmethod update-instance-for-redefined-class ((instance standard-object)
    3809             added-slots
    3810             discarded-slots
    3811             property-list
    3812             &rest initargs)
     3809                                                added-slots
     3810                                                discarded-slots
     3811                                                property-list
     3812                                                &rest initargs)
    38133813  (check-initargs (list #'update-instance-for-redefined-class)
    38143814                  (list* instance added-slots discarded-slots
    … …  
    41444144      (when (eq (car option) :report)
    41454145        (setf report (cadr option))
    4146   (setf options (delete option options :test #'equal))
     4146        (setf options (delete option options :test #'equal))
    41474147        (return)))
    41484148    (typecase report
    41494149      (null
    41504150       `(progn
    4151     (sys::record-source-information-for-type  ',name :condition)
     4151          (sys::record-source-information-for-type  ',name :condition)
    41524152          (defclass ,name ,parent-types ,slot-specs ,@options)
    41534153          ',name))
    41544154      (string
    41554155       `(progn
    4156     (sys::record-source-information-for-type  ',name :condition)
     4156          (sys::record-source-information-for-type  ',name :condition)
    41574157          (defclass ,name ,parent-types ,slot-specs ,@options)
    41584158          (defmethod print-object ((condition ,name) stream)
    … …  
    41634163      (t
    41644164       `(progn
    4165     (sys::record-source-information-for-type  ',name :condition)
     4165          (sys::record-source-information-for-type  ',name :condition)
    41664166          (defclass ,name ,parent-types ,slot-specs ,@options)
    41674167          (defmethod print-object ((condition ,name) stream)
    … …  
    45604560                 (autoload-ref-p (second function-name))))
    45614561        (fmakunbound function-name)
    4562   (progn
    4563     (cerror "Redefine as generic function" "~A already names an ordinary function, macro, or special operator." function-name)
    4564     (fmakunbound function-name)
    4565     )))
     4562        (progn
     4563          (cerror "Redefine as generic function" "~A already names an ordinary function, macro, or special operator." function-name)
     4564          (fmakunbound function-name)
     4565          )))
    45664566  (apply (if (eq generic-function-class +the-standard-generic-function-class+)
    45674567             #'make-instance-standard-generic-function

  • trunk/abcl/src/org/armedbear/lisp/collect.lisp

    r11391 r15569  
    5959    `(progn
    6060      ,@(mapcar #'(lambda (form)
    61         `(let ((,n-res (cons ,form nil)))
    62            (cond (,n-tail
    63             (setf (cdr ,n-tail) ,n-res)
    64             (setq ,n-tail ,n-res))
    65            (t
    66             (setq ,n-tail ,n-res  ,n-value ,n-res)))))
    67     forms)
     61                    `(let ((,n-res (cons ,form nil)))
     62                       (cond (,n-tail
     63                              (setf (cdr ,n-tail) ,n-res)
     64                              (setq ,n-tail ,n-res))
     65                             (t
     66                              (setq ,n-tail ,n-res  ,n-value ,n-res)))))
     67                forms)
    6868      ,n-value)))
    6969
    … …  
    9494
    9595  (let ((macros ())
    96   (binds ()))
     96        (binds ()))
    9797    (dolist (spec collections)
    9898      (unless (<= 1 (length spec) 3)
    99   (error "Malformed collection specifier: ~S." spec))
     99        (error "Malformed collection specifier: ~S." spec))
    100100      (let ((n-value (gensym))
    101       (name (first spec))
    102       (default (second spec))
    103       (kind (or (third spec) 'collect)))
    104   (push `(,n-value ,default) binds)
    105   (if (eq kind 'collect)
    106       (let ((n-tail (gensym)))
    107         (if default
    108       (push `(,n-tail (last ,n-value)) binds)
    109       (push n-tail binds))
    110         (push `(,name (&rest args)
    111           (collect-list-expander ',n-value ',n-tail args))
    112         macros))
    113       (push `(,name (&rest args)
    114         (collect-normal-expander ',n-value ',kind args))
    115       macros))))
     101            (name (first spec))
     102            (default (second spec))
     103            (kind (or (third spec) 'collect)))
     104        (push `(,n-value ,default) binds)
     105        (if (eq kind 'collect)
     106            (let ((n-tail (gensym)))
     107              (if default
     108                  (push `(,n-tail (last ,n-value)) binds)
     109                  (push n-tail binds))
     110              (push `(,name (&rest args)
     111                            (collect-list-expander ',n-value ',n-tail args))
     112                    macros))
     113            (push `(,name (&rest args)
     114                          (collect-normal-expander ',n-value ',kind args))
     115                  macros))))
    116116    `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
    117117

  • trunk/abcl/src/org/armedbear/lisp/compile-file.lisp

    r15484 r15569  
    6161  (let ((name
    6262         (sanitize-class-name
    63     (%format nil "~A_~D" (pathname-name output-file-pathname) n))))
     63          (%format nil "~A_~D" (pathname-name output-file-pathname) n))))
    6464    (merge-pathnames (make-pathname :name name :type *compile-file-class-extension*)
    6565                                 output-file-pathname)))
    … …  
    7070      (declare (type fixnum i))
    7171      (when (or (char= (char name i) #\-)
    72     (char= (char name i) #\.)
    73     (char= (char name i) #\Space))
     72                (char= (char name i) #\.)
     73                (char= (char name i) #\Space))
    7474        (setf (char name i) #\_)))
    7575    name))
    … …  
    315315  (declare (ignore stream compile-time-too))
    316316  (let* ((name (second form))
    317   (type (third form)))
     317        (type (third form)))
    318318    (when (quoted-form-p name) (setq name (second name)))
    319319    (when (quoted-form-p type) (setq type (second type)))
    … …  
    321321      `(sys:put ',sym 'sys::source
    322322                (cl:cons '(,type ,(namestring *source*) ,*source-position*)
    323       (cl:get ',sym  'sys::source nil))))))
    324 
    325    
     323                        (cl:get ',sym  'sys::source nil))))))
     324
     325         
    326326(declaim (ftype (function (t t t) t) process-toplevel-mop.ensure-method))
    327327(defun process-toplevel-mop.ensure-method (form stream compile-time-too)
    … …  
    407407  (let ((defpackage-name (and (eq (car form) 'defpackage) (intern (string (second form)) :keyword))) )
    408408    (setf form
    409     (precompiler:precompile-form form nil *compile-file-environment*))
     409          (precompiler:precompile-form form nil *compile-file-environment*))
    410410    (eval form)
    411411    ;; Force package prefix to be used when dumping form.
    … …  
    418418    ;; it is a string by now) (if it is a defpackage)
    419419    (if defpackage-name
    420   `(sys:put ,defpackage-name 'sys::source
    421             (cl:cons '(:package ,(namestring *source*) ,*source-position*)
    422                (cl:get ,defpackage-name 'sys::source nil)))
    423   nil)))
     420        `(sys:put ,defpackage-name 'sys::source
     421                  (cl:cons '(:package ,(namestring *source*) ,*source-position*)
     422                           (cl:get ,defpackage-name 'sys::source nil)))
     423        nil)))
    424424
    425425(declaim (ftype (function (t t t) t) process-toplevel-declare))
    … …  
    486486  (let ((*compile-print* nil))
    487487    (process-toplevel-form (macroexpand-1 form *compile-file-environment*)
    488            stream compile-time-too))
     488                           stream compile-time-too))
    489489  (let* ((sym (if (consp (second form)) (second (second form)) (second form))))
    490490    (when (eq (car form) 'defgeneric)
    491491      `(progn
    492   (sys:put ',sym 'sys::source
    493             (cl:cons '((:generic-function ,(second form))
     492        (sys:put ',sym 'sys::source
     493                  (cl:cons '((:generic-function ,(second form))
    494494                             ,(namestring *source*) ,*source-position*)
    495495                           (cl:get ',sym  'sys::source nil)))
    496   ,@(loop for method-form in (cdddr form)
    497     when (eq (car method-form) :method)
    498        collect
    499        (multiple-value-bind (function-name qualifiers lambda-list specializers documentation declarations body)
    500            (mop::parse-defmethod `(,(second form) ,@(rest method-form)))
     496        ,@(loop for method-form in (cdddr form)
     497                when (eq (car method-form) :method)
     498                   collect
     499                   (multiple-value-bind (function-name qualifiers lambda-list specializers documentation declarations body)
     500                       (mop::parse-defmethod `(,(second form) ,@(rest method-form)))
    501501                     ;;; FIXME: style points for refactoring double backquote to "normal" form
    502          `(sys:put ',sym 'sys::source
    503              (cl:cons `((:method ,',sym ,',qualifiers ,',specializers)
     502                     `(sys:put ',sym 'sys::source
     503                               (cl:cons `((:method ,',sym ,',qualifiers ,',specializers)
    504504                                          ,,(namestring *source*) ,,*source-position*)
    505                 (cl:get ',sym  'sys::source nil)))))))))
     505                                        (cl:get ',sym  'sys::source nil)))))))))
    506506
    507507
    … …  
    548548                                (sys::get-fasl-function *fasl-loader*
    549549                                                        ,saved-class-number)))
    550     `(progn
    551        (sys:put ',name 'sys::source
    552           (cl:cons '(:macro ,(namestring *source*) ,*source-position*)
     550          `(progn
     551             (sys:put ',name 'sys::source
     552                      (cl:cons '(:macro ,(namestring *source*) ,*source-position*)
    553553                               (cl:get ',name  'sys::source nil)))
    554        (sys:fset ',name
    555            (sys:make-macro ',name
    556                      (sys::get-fasl-function *fasl-loader*
    557                            ,saved-class-number))
    558            ,*source-position*
    559            ',(third form)
    560            ,(%documentation name 'cl:function)))))))
     554             (sys:fset ',name
     555                       (sys:make-macro ',name
     556                                       (sys::get-fasl-function *fasl-loader*
     557                                                               ,saved-class-number))
     558                       ,*source-position*
     559                       ',(third form)
     560                       ,(%documentation name 'cl:function)))))))
    561561
    562562(declaim (ftype (function (t t t) t) process-toplevel-defun))
    … …  
    598598               (when compile-time-too
    599599                 (eval form))
    600          (let ((sym (if (consp name) (second name) name)))
    601     (setf form
    602            `(progn
    603         (sys:put ',sym 'sys::source
     600               (let ((sym (if (consp name) (second name) name)))
     601                (setf form
     602                       `(progn
     603                          (sys:put ',sym 'sys::source
    604604                                   (cl:cons '((:function ,name)
    605605                                              ,(namestring *source*) ,*source-position*)
    606                                             (cl:get ',sym  'sys::source nil)))           
    607         (sys:fset ',name
     606                                            (cl:get ',sym  'sys::source nil)))                 
     607                          (sys:fset ',name
    608608                                    (sys::get-fasl-function *fasl-loader*
    609609                                                            ,saved-class-number)
    … …  
    640640    (push name *toplevel-functions*)
    641641    (when (and (consp name)
    642          (or
     642               (or
    643643                (eq 'setf (first name))
    644     (eq 'cl:setf (first name))))
     644                (eq 'cl:setf (first name))))
    645645      (push (second name) *toplevel-setf-functions*))
    646646    ;; If NAME is not fbound, provide a dummy definition so that
    … …  
    685685                (%SET-FDEFINITION precompile-toplevel-form)
    686686                (MOP::ENSURE-METHOD process-toplevel-mop.ensure-method)
    687     (record-source-information-for-type process-record-source-information)))
     687                (record-source-information-for-type process-record-source-information)))
    688688  (install-toplevel-handler (car pair) (cadr pair)))
    689689
    … …  
    815815
    816816    (write `(in-package ,(package-name in-package))
    817      :stream out)
     817           :stream out)
    818818    (%stream-terpri out)))
    819819
    … …  
    990990              (loop for line = (read-line in nil :eof)
    991991                 while (not (eq line :eof))
    992         do (write-line line out)))))
     992                    do (write-line line out)))))
    993993        (delete-file temp-file)
    994994        (when (subtypep (type-of output-file) 'jar-pathname)

  • trunk/abcl/src/org/armedbear/lisp/compile-system.lisp

    r14931 r15569  
    488488(defun compile-system (&key quit (zip t) (cls-ext *compile-file-class-extension*) (abcl-ext *compile-file-type*) output-path)
    489489  (let ((status -1)
    490   (*compile-file-class-extension* cls-ext)
    491   (*compile-file-type* abcl-ext))
     490        (*compile-file-class-extension* cls-ext)
     491        (*compile-file-type* abcl-ext))
    492492    (check-lisp-home)
    493493    (time

  • trunk/abcl/src/org/armedbear/lisp/compiler-macro.lisp

    r14914 r15569  
    6262                         (block ,block-name ,body))))
    6363        `(progn
    64      (record-source-information-for-type ',name :compiler-macro)
     64           (record-source-information-for-type ',name :compiler-macro)
    6565           (setf (compiler-macro-function ',name) (function ,expander))
    6666           ',name)))))

  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r15223 r15569  
    951951  (let* ((*compiler-debug* nil)
    952952         (method (make-jvm-method :constructor :void nil
    953           :flags '(:public)))
     953                                  :flags '(:public)))
    954954         ;; We don't normally need to see debugging output for constructors.
    955955         (super (class-file-superclass class))
    … …  
    39243924    (with-operand-accumulation
    39253925         ((emit-variable-operand (block-id-variable block))
    3926     (emit-load-externalized-object-operand (block-name block))
    3927     (compile-operand result-form nil))
     3926          (emit-load-externalized-object-operand (block-name block))
     3927          (compile-operand result-form nil))
    39283928       (emit-invokestatic +lisp+ "nonLocalReturn" (lisp-object-arg-types 3)
    3929         +lisp-object+))
     3929                          +lisp-object+))
    39303930    ;; Following code will not be reached, but is needed for JVM stack
    39313931    ;; consistency.
    … …  
    39423942           (compile-form arg target nil))
    39433943          ((and (consp arg) (eq (%car arg) 'cdr) (= (length arg) 2))
    3944      (compile-forms-and-maybe-emit-clear-values (second arg) 'stack nil)
     3944           (compile-forms-and-maybe-emit-clear-values (second arg) 'stack nil)
    39453945           (emit-invoke-method "cadr" target representation))
    39463946          (t
    … …  
    40064006    (with-operand-accumulation
    40074007        ((compile-operand symbols-form nil)
    4008   (compile-operand values-form nil))
     4008        (compile-operand values-form nil))
    40094009      (unless (and (single-valued-p symbols-form)
    4010        (single-valued-p values-form))
    4011   (emit-clear-values))
     4010                   (single-valued-p values-form))
     4011        (emit-clear-values))
    40124012      (save-dynamic-environment environment-register)
    40134013      ;; Compile call to Lisp.progvBindVars().
    40144014      (emit-push-current-thread)
    40154015      (emit-invokestatic +lisp+ "progvBindVars"
    4016       (list +lisp-object+ +lisp-object+ +lisp-thread+) nil))
     4016                        (list +lisp-object+ +lisp-object+ +lisp-thread+) nil))
    40174017      ;; Implicit PROGN.
    40184018    (let ((*blocks* (cons block *blocks*)))
    … …  
    69026902       (compile-operand (third form) nil)) ; Result.
    69036903    (emit-invokevirtual +lisp-thread+ "throwToTag"
    6904       (lisp-object-arg-types 2) nil))
     6904                        (lisp-object-arg-types 2) nil))
    69056905  ;; Following code will not be reached.
    69066906  (when target
    … …  
    74317431  `(lambda ,(cadr form)
    74327432     (error 'program-error :format-control "Program error while compiling ~a" :format-arguments
    7433       (if ,condition
    7434     (list (apply 'format nil ,(slot-value condition 'sys::format-control) ',(slot-value condition 'sys::format-arguments)))
    7435     (list "a form")))))
     7433            (if ,condition
     7434                (list (apply 'format nil ,(slot-value condition 'sys::format-control) ',(slot-value condition 'sys::format-arguments)))
     7435                (list "a form")))))
    74367436
    74377437(defun compile-defun (name form environment filespec stream *declare-inline*)

  • trunk/abcl/src/org/armedbear/lisp/cond.lisp

    r11391 r15569  
    3636      nil
    3737      (let ((clause (first clauses)))
    38   (when (atom clause)
    39     (error "COND clause is not a list: ~S" clause))
    40   (let ((test (first clause))
    41         (forms (rest clause)))
    42     (if (endp forms)
    43         (let ((n-result (gensym)))
    44     `(let ((,n-result ,test))
    45        (if ,n-result
    46            ,n-result
    47            (cond ,@(rest clauses)))))
    48         `(if ,test
    49        (progn ,@forms)
    50        (cond ,@(rest clauses))))))))
     38        (when (atom clause)
     39          (error "COND clause is not a list: ~S" clause))
     40        (let ((test (first clause))
     41              (forms (rest clause)))
     42          (if (endp forms)
     43              (let ((n-result (gensym)))
     44                `(let ((,n-result ,test))
     45                   (if ,n-result
     46                       ,n-result
     47                       (cond ,@(rest clauses)))))
     48              `(if ,test
     49                   (progn ,@forms)
     50                   (cond ,@(rest clauses))))))))

  • trunk/abcl/src/org/armedbear/lisp/copy-seq.lisp

    r12516 r15569  
    3939  `(let ((length (length ,sequence)))
    4040     (do ((index 0 (1+ index))
    41     (copy (make-sequence-of-type ,type length)))
     41          (copy (make-sequence-of-type ,type length)))
    4242       ((= index length) copy)
    4343       (aset copy index (aref ,sequence index)))))
    … …  
    4646  `(if (atom ,list) '()
    4747       (let ((result (cons (car ,list) '()) ))
    48   (do ((x (cdr ,list) (cdr x))
    49         (splice result
    50           (cdr (rplacd splice (cons (car x) '() ))) ))
     48        (do ((x (cdr ,list) (cdr x))
     49              (splice result
     50                      (cdr (rplacd splice (cons (car x) '() ))) ))
    5151           ((atom x) (unless (null x)
    5252                       (rplacd splice x))

  • trunk/abcl/src/org/armedbear/lisp/count.lisp

    r12516 r15569  
    6060
    6161(defun count (item sequence &rest args &key from-end (test #'eql test-p) (test-not nil test-not-p)
    62        (start 0) end key)
     62                   (start 0) end key)
    6363  (when (and test-p test-not-p)
    6464    (error "test and test-not both supplied"))
    6565  (let* ((length (length sequence))
    66   (end (or end length)))
     66        (end (or end length)))
    6767    (let ((%test (if test-not-p
    68          (lambda (x)
    69            (not (funcall test-not item x)))
    70          (lambda (x)
    71            (funcall test item x)))))
     68                     (lambda (x)
     69                       (not (funcall test-not item x)))
     70                     (lambda (x)
     71                       (funcall test item x)))))
    7272      (sequence::seq-dispatch sequence
    73   (if from-end
    74       (list-count-if nil t %test sequence)
    75       (list-count-if nil nil %test sequence))
    76   (if from-end
    77       (vector-count-if nil t %test sequence)
    78       (vector-count-if nil nil %test sequence))
    79   (apply #'sequence:count item sequence args)))))
     73        (if from-end
     74            (list-count-if nil t %test sequence)
     75            (list-count-if nil nil %test sequence))
     76        (if from-end
     77            (vector-count-if nil t %test sequence)
     78            (vector-count-if nil nil %test sequence))
     79        (apply #'sequence:count item sequence args)))))
    8080
    8181(defun count-if (test sequence &rest args &key from-end (start 0) end key)
    8282  (let* ((length (length sequence))
    83   (end (or end length)))
     83        (end (or end length)))
    8484    (sequence::seq-dispatch sequence
    8585        (if from-end
    … …  
    8989            (vector-count-if nil t test sequence)
    9090            (vector-count-if nil nil test sequence))
    91   (apply #'sequence:count-if test sequence args))))
     91        (apply #'sequence:count-if test sequence args))))
    9292
    9393(defun count-if-not (test sequence &rest args &key from-end (start 0) end key)
    9494  (let* ((length (length sequence))
    95   (end (or end length)))
     95        (end (or end length)))
    9696    (sequence::seq-dispatch sequence
    9797        (if from-end
    … …  
    101101            (vector-count-if t t test sequence)
    102102            (vector-count-if t nil test sequence))
    103   (apply #'sequence:count-if-not test sequence args))))
     103        (apply #'sequence:count-if-not test sequence args))))

  • trunk/abcl/src/org/armedbear/lisp/debug.lisp

    r13434 r15569  
    8787    (with-standard-io-syntax
    8888      (let ((*print-structure* nil)
    89       (*print-readably* nil))
     89            (*print-readably* nil))
    9090        (when (and *load-truename* (streamp *load-stream*))
    9191          (simple-format *debug-io*

  • trunk/abcl/src/org/armedbear/lisp/define-modify-macro.lisp

    r14727 r15569  
    3838  "Creates a new read-modify-write macro like PUSH or INCF."
    3939  (let ((other-args nil)
    40   (rest-arg nil)
    41   (env (gensym))
    42   (reference (gensym)))
     40        (rest-arg nil)
     41        (env (gensym))
     42        (reference (gensym)))
    4343    ;; Parse out the variable names and &REST arg from the lambda list.
    4444    (do ((ll lambda-list (cdr ll))
    45   (arg nil))
    46   ((null ll))
     45        (arg nil))
     46        ((null ll))
    4747      (setq arg (car ll))
    4848      (cond ((eq arg '&optional))
    49       ((eq arg '&rest)
    50        (if (symbolp (cadr ll))
    51     (setq rest-arg (cadr ll))
    52     (error "Non-symbol &REST arg in definition of ~S." name))
    53        (if (null (cddr ll))
    54     (return nil)
    55     (error "Illegal stuff after &REST argument in DEFINE-MODIFY-MACRO.")))
    56       ((memq arg '(&key &allow-other-keys &aux))
    57        (error "~S not allowed in DEFINE-MODIFY-MACRO lambda list." arg))
    58       ((symbolp arg)
    59        (push arg other-args))
    60       ((and (listp arg) (symbolp (car arg)))
    61        (push (car arg) other-args))
    62       (t (error "Illegal stuff in DEFINE-MODIFY-MACRO lambda list."))))
     49            ((eq arg '&rest)
     50             (if (symbolp (cadr ll))
     51                (setq rest-arg (cadr ll))
     52                (error "Non-symbol &REST arg in definition of ~S." name))
     53             (if (null (cddr ll))
     54                (return nil)
     55                (error "Illegal stuff after &REST argument in DEFINE-MODIFY-MACRO.")))
     56            ((memq arg '(&key &allow-other-keys &aux))
     57             (error "~S not allowed in DEFINE-MODIFY-MACRO lambda list." arg))
     58            ((symbolp arg)
     59             (push arg other-args))
     60            ((and (listp arg) (symbolp (car arg)))
     61             (push (car arg) other-args))
     62            (t (error "Illegal stuff in DEFINE-MODIFY-MACRO lambda list."))))
    6363    (setq other-args (nreverse other-args))
    6464    `(eval-when (:compile-toplevel :load-toplevel :execute)

  • trunk/abcl/src/org/armedbear/lisp/defmacro.lisp

    r14914 r15569  
    4242      (let ((expander `(lambda (,whole ,env) ,@decls ,body)))
    4343        `(progn
    44      (sys::record-source-information-for-type ',name :macro)
     44           (sys::record-source-information-for-type ',name :macro)
    4545           (let ((macro (make-macro ',name
    4646                                    (or (precompile nil ,expander) ,expander))))

  • trunk/abcl/src/org/armedbear/lisp/defpackage.lisp

    r14914 r15569  
    155155    `(prog1
    156156       (%defpackage ,(string package) ',nicknames ',size
    157         ',shadows (ensure-available-symbols ',shadowing-imports)
    158         ',(if use-p use nil)
    159         (ensure-available-symbols ',imports) ',interns ',exports
    160         ',local-nicknames ',doc)
     157                    ',shadows (ensure-available-symbols ',shadowing-imports)
     158                    ',(if use-p use nil)
     159                    (ensure-available-symbols ',imports) ',interns ',exports
     160                    ',local-nicknames ',doc)
    161161       ,(when (and (symbolp package) (not (keywordp package)))
    162     `(record-source-information-for-type ',package :package))
     162          `(record-source-information-for-type ',package :package))
    163163       (record-source-information-for-type ,(intern (string package) :keyword) :package)
    164164       )))

  • trunk/abcl/src/org/armedbear/lisp/defsetf.lisp

    r11391 r15569  
    5555(defmacro defsetf (access-fn &rest rest)
    5656  (cond ((not (listp (car rest)))
    57   `(eval-when (:load-toplevel :compile-toplevel :execute)
    58       (%define-setf-macro ',access-fn
     57        `(eval-when (:load-toplevel :compile-toplevel :execute)
     58            (%define-setf-macro ',access-fn
    5959                                nil
    6060                                ',(car rest)
    61         ,(when (and (car rest) (stringp (cadr rest)))
    62            `',(cadr rest)))))
    63   ((and (cdr rest) (listp (cadr rest)))
    64   (destructuring-bind
     61                                ,(when (and (car rest) (stringp (cadr rest)))
     62                                   `',(cadr rest)))))
     63        ((and (cdr rest) (listp (cadr rest)))
     64        (destructuring-bind
    6565          (lambda-list (&rest store-variables) &body body)
    6666          rest
    … …  
    8484                  nil
    8585                  ',doc))))))
    86   (t
    87   (error "Ill-formed DEFSETF for ~S" access-fn))))
     86        (t
     87        (error "Ill-formed DEFSETF for ~S" access-fn))))

  • trunk/abcl/src/org/armedbear/lisp/defstruct.lisp

    r15030 r15569  
    354354    (cond ((eq *dd-type* 'list)
    355355           `((declaim (ftype (function * ,type) ,accessor-name))
    356        (record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
     356             (record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
    357357             (setf (symbol-function ',accessor-name)
    358358                   (make-list-reader ,index))))
    … …  
    360360               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
    361361           `((declaim (ftype (function * ,type) ,accessor-name))
    362        (record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
     362             (record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
    363363             (setf (symbol-function ',accessor-name)
    364364                   (make-vector-reader ,index))
    365        (record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
     365             (record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
    366366             (define-source-transform ,accessor-name (instance)
    367367               `(aref (truly-the ,',*dd-type* ,instance) ,,index))))
    … …  
    370370             (setf (symbol-function ',accessor-name)
    371371                   (make-structure-reader ,index ',*dd-name*))
    372        (record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
     372             (record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
    373373             (define-source-transform ,accessor-name (instance)
    374374               ,(if (eq type 't)
    … …  
    401401    (cond ((eq *dd-type* 'list)
    402402           `((record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
    403        (setf (get ',accessor-name 'setf-function)
     403             (setf (get ',accessor-name 'setf-function)
    404404                   (make-list-writer ,index))))
    405405          ((or (eq *dd-type* 'vector)
    … …  
    407407           `((setf (get ',accessor-name 'setf-function)
    408408                   (make-vector-writer ,index))
    409        (record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
     409             (record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
    410410             (define-source-transform (setf ,accessor-name) (value instance)
    411411               `(aset (truly-the ,',*dd-type* ,instance) ,,index ,value))))
    … …  
    413413           `((setf (get ',accessor-name 'setf-function)
    414414                   (make-structure-writer ,index ',*dd-name*))
    415        (record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
     415             (record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
    416416             (define-source-transform (setf ,accessor-name) (value instance)
    417417               `(structure-set (the ,',*dd-name* ,instance)

  • trunk/abcl/src/org/armedbear/lisp/delete-duplicates.lisp

    r12516 r15569  
    3939  (let ((handle (cons nil list)))
    4040    (do ((current (nthcdr start list) (cdr current))
    41   (previous (nthcdr start handle))
    42   (index start (1+ index)))
     41        (previous (nthcdr start handle))
     42        (index start (1+ index)))
    4343      ((or (and end (= index end)) (null current))
    4444       (cdr handle))
    4545      (if (do ((x (if from-end
    46           (nthcdr (1+ start) handle)
    47           (cdr current))
    48       (cdr x))
    49          (i (1+ index) (1+ i)))
     46                      (nthcdr (1+ start) handle)
     47                      (cdr current))
     48                  (cdr x))
     49               (i (1+ index) (1+ i)))
    5050            ((or (null x)
    5151                 (and (not from-end) end (= i end))
    5252                 (eq x current))
    5353             nil)
    54       (if (if test-not
    55         (not (funcall test-not
    56           (sys::apply-key key (car current))
    57           (sys::apply-key key (car x))))
    58         (funcall test
    59            (sys::apply-key key (car current))
    60            (sys::apply-key key (car x))))
    61     (return t)))
    62     (rplacd previous (cdr current))
    63     (setq previous (cdr previous))))))
     54            (if (if test-not
     55                    (not (funcall test-not
     56                                  (sys::apply-key key (car current))
     57                                  (sys::apply-key key (car x))))
     58                    (funcall test
     59                             (sys::apply-key key (car current))
     60                             (sys::apply-key key (car x))))
     61                (return t)))
     62          (rplacd previous (cdr current))
     63          (setq previous (cdr previous))))))
    6464
    6565
    6666(defun vector-delete-duplicates* (vector test test-not key from-end start end
    67           &optional (length (length vector)))
     67                                        &optional (length (length vector)))
    6868  (when (null end) (setf end (length vector)))
    6969  (do ((index start (1+ index))
    7070       (jndex start))
    7171    ((= index end)
    72      (do ((index index (1+ index))    ; copy the rest of the vector
     72     (do ((index index (1+ index))              ; copy the rest of the vector
    7373          (jndex jndex (1+ jndex)))
    7474       ((= index length)
    … …  
    7878    (setf (aref vector jndex) (aref vector index))
    7979    (unless (position (sys::apply-key key (aref vector index)) vector :key key
    80           :start (if from-end start (1+ index)) :test test
    81           :end (if from-end jndex end) :test-not test-not)
     80                      :start (if from-end start (1+ index)) :test test
     81                      :end (if from-end jndex end) :test-not test-not)
    8282      (setq jndex (1+ jndex)))))
    8383
    8484(defun delete-duplicates (sequence &rest args &key (test #'eql) test-not
    85         (start 0) from-end end key)
     85                          (start 0) from-end end key)
    8686  (sequence::seq-dispatch sequence
    8787    (if sequence
    88   (list-delete-duplicates* sequence test test-not key from-end start end))
     88        (list-delete-duplicates* sequence test test-not key from-end start end))
    8989    (vector-delete-duplicates* sequence test test-not key from-end start end)
    9090    (apply #'sequence:delete-duplicates sequence args)))

  • trunk/abcl/src/org/armedbear/lisp/delete.lisp

    r12516 r15569  
    4747        (number-zapped 0))
    4848     ((or (= index end) (= number-zapped count))
    49       (do ((index index (1+ index))   ; copy the rest of the vector
     49      (do ((index index (1+ index))             ; copy the rest of the vector
    5050           (jndex jndex (1+ jndex)))
    5151        ((= index length)
    … …  
    6464        (terminus (1- start)))
    6565     ((or (= index terminus) (= number-zapped count))
    66       (do ((losers losers)      ; delete the losers
     66      (do ((losers losers)                      ; delete the losers
    6767           (index start (1+ index))
    6868           (jndex start))
    6969        ((or (null losers) (= index end))
    70          (do ((index index (1+ index))  ; copy the rest of the vector
     70         (do ((index index (1+ index))  ; copy the rest of the vector
    7171              (jndex jndex (1+ jndex)))
    7272           ((= index length)
    … …  
    137137
    138138(defun delete (item sequence &rest args &key from-end (test #'eql) test-not
    139          (start 0) end count key)
     139               (start 0) end count key)
    140140  (when key
    141141    (setq key (coerce-to-function key)))
    142142  (let* ((length (length sequence))
    143   (end (or end length))
    144   (count (real-count count)))
     143        (end (or end length))
     144        (count (real-count count)))
    145145    (sequence::seq-dispatch sequence
    146146      (if from-end
    147     (normal-list-delete-from-end)
    148     (normal-list-delete))
    149       (if from-end
    150     (normal-mumble-delete-from-end)
    151     (normal-mumble-delete))
     147          (normal-list-delete-from-end)
     148          (normal-list-delete))
     149      (if from-end
     150          (normal-mumble-delete-from-end)
     151          (normal-mumble-delete))
    152152      (apply #'sequence:delete item sequence args))))
    153153
    … …  
    169169
    170170(defun delete-if (predicate sequence &rest args &key from-end (start 0)
    171       key end count)
     171                  key end count)
    172172  (when key
    173173    (setq key (coerce-to-function key)))
    174174  (let* ((length (length sequence))
    175   (end (or end length))
    176   (count (real-count count)))
     175        (end (or end length))
     176        (count (real-count count)))
    177177    (sequence::seq-dispatch sequence
    178178      (if from-end
    179     (if-list-delete-from-end)
    180     (if-list-delete))
    181       (if from-end
    182     (if-mumble-delete-from-end)
    183     (if-mumble-delete))
     179          (if-list-delete-from-end)
     180          (if-list-delete))
     181      (if from-end
     182          (if-mumble-delete-from-end)
     183          (if-mumble-delete))
    184184      (apply #'sequence:delete-if predicate sequence args))))
    185185
    … …  
    201201
    202202(defun delete-if-not (predicate sequence &rest args &key from-end (start 0)
    203           end key count)
     203                      end key count)
    204204  (when key
    205205    (setq key (coerce-to-function key)))
    206206  (let* ((length (length sequence))
    207   (end (or end length))
    208   (count (real-count count)))
     207        (end (or end length))
     208        (count (real-count count)))
    209209    (sequence::seq-dispatch sequence
    210210      (if from-end
    211     (if-not-list-delete-from-end)
    212     (if-not-list-delete))
    213       (if from-end
    214     (if-not-mumble-delete-from-end)
    215     (if-not-mumble-delete))
     211          (if-not-list-delete-from-end)
     212          (if-not-list-delete))
     213      (if from-end
     214          (if-not-mumble-delete-from-end)
     215          (if-not-mumble-delete))
    216216      (apply #'sequence:delete-if-not predicate sequence args))))

  • trunk/abcl/src/org/armedbear/lisp/delete_file.java

    r15411 r15569  
    8888          if (file.delete()) {
    8989            return T;
    90     }
    91     // Under Windows our fasls get placed in the ZipCache when compiled
    92     ZipCache.remove(defaultedPathname);
     90          }
     91          // Under Windows our fasls get placed in the ZipCache when compiled
     92          ZipCache.remove(defaultedPathname);
    9393          System.gc();
    9494          Thread.yield();

  • trunk/abcl/src/org/armedbear/lisp/describe.lisp

    r14956 r15569  
    9595       (describe-arglist object stream)
    9696       (let ((function-symbol (nth-value 2 (function-lambda-expression object))))
    97   (if (and (consp function-symbol) (eq (car function-symbol) 'macro-function))
    98        (setq function-symbol (second function-symbol)))
    99   (when  function-symbol
    100      (let ((doc (documentation function-symbol 'function)))
    101        (when doc
    102          (format stream "Function documentation:~%  ~A~%" doc)))
    103      )))
     97        (if (and (consp function-symbol) (eq (car function-symbol) 'macro-function))
     98             (setq function-symbol (second function-symbol)))
     99        (when  function-symbol
     100           (let ((doc (documentation function-symbol 'function)))
     101             (when doc
     102               (format stream "Function documentation:~%  ~A~%" doc)))
     103           )))
    104104      (INTEGER
    105105       (%describe-object object stream)

  • trunk/abcl/src/org/armedbear/lisp/destructuring-bind.lisp

    r15095 r15569  
    3838(defun parse-body (body &optional (doc-string-allowed t))
    3939  (let ((decls ())
    40   (doc nil))
     40        (doc nil))
    4141    (do ((tail body (cdr tail)))
    42   ((endp tail)
    43   (values tail (nreverse decls) doc))
     42        ((endp tail)
     43        (values tail (nreverse decls) doc))
    4444      (let ((form (car tail)))
    45   (cond ((and (stringp form) (cdr tail))
    46          (if doc-string-allowed
    47        (setq doc form
    48       ;; Only one doc string is allowed.
    49       doc-string-allowed nil)
    50        (return (values tail (nreverse decls) doc))))
    51         ((not (and (consp form) (symbolp (car form))))
    52          (return (values tail (nreverse decls) doc)))
    53         ((eq (car form) 'declare)
    54          (push form decls))
    55         (t
    56          (return (values tail (nreverse decls) doc))))))))
     45        (cond ((and (stringp form) (cdr tail))
     46               (if doc-string-allowed
     47                   (setq doc form
     48                        ;; Only one doc string is allowed.
     49                        doc-string-allowed nil)
     50                   (return (values tail (nreverse decls) doc))))
     51              ((not (and (consp form) (symbolp (car form))))
     52               (return (values tail (nreverse decls) doc)))
     53              ((eq (car form) 'declare)
     54               (push form decls))
     55              (t
     56               (return (values tail (nreverse decls) doc))))))))
    5757
    5858;; We don't have DEFVAR yet...
    … …  
    7777(defun lambda-list-broken-key-list-error (&key kind name problem info)
    7878  (error 'program-error
    79   :format-control (concatenate 'string "Error while parsing arguments to ~A ~S:~%"
    80               (ecase problem
    81           (:dotted-list
    82           "Keyword/value list is dotted: ~S")
    83           (:odd-length
    84           "Odd number of elements in keyword/value list: ~S")
    85           (:duplicate
    86           "Duplicate keyword: ~S")
    87           (:unknown-keyword
    88           "~{Unknown keyword: ~S ; expected one of ~{~S~^, ~}~}")))
    89   :format-arguments (list kind name info)))
     79        :format-control (concatenate 'string "Error while parsing arguments to ~A ~S:~%"
     80                                      (ecase problem
     81                                        (:dotted-list
     82                                        "Keyword/value list is dotted: ~S")
     83                                        (:odd-length
     84                                        "Odd number of elements in keyword/value list: ~S")
     85                                        (:duplicate
     86                                        "Duplicate keyword: ~S")
     87                                        (:unknown-keyword
     88                                        "~{Unknown keyword: ~S ; expected one of ~{~S~^, ~}~}")))
     89        :format-arguments (list kind name info)))
    9090
    9191;;; Return, as multiple values, a body, possibly a DECLARE form to put
    … …  
    9393;;; body, and bounds on the number of arguments.
    9494(defun parse-defmacro (lambda-list arg-list-name body name context
    95            &key
    96            (anonymousp nil)
    97            (doc-string-allowed t)
    98            ((:environment env-arg-name))
    99            (error-fun 'error)
     95                                   &key
     96                                   (anonymousp nil)
     97                                   (doc-string-allowed t)
     98                                   ((:environment env-arg-name))
     99                                   (error-fun 'error)
    100100                                   (wrap-block t))
    101101  (multiple-value-bind (forms declarations documentation)
    102102      (parse-body body doc-string-allowed)
    103103    (let ((*arg-tests* ())
    104     (*user-lets* ())
    105     (*system-lets* ())
    106     (*ignorable-vars* ())
     104          (*user-lets* ())
     105          (*system-lets* ())
     106          (*ignorable-vars* ())
    107107          (*env-var* nil))
    108108      (multiple-value-bind (env-arg-used minimum maximum)
    109     (parse-defmacro-lambda-list lambda-list arg-list-name name
    110               context error-fun (not anonymousp)
    111               nil)
    112   (values `(let* (,@(when env-arg-used
     109          (parse-defmacro-lambda-list lambda-list arg-list-name name
     110                                      context error-fun (not anonymousp)
     111                                      nil)
     112        (values `(let* (,@(when env-arg-used
    113113                            `((,*env-var* ,env-arg-name)))
    114114                        ,@(nreverse *system-lets*))
    115        ,@(when *ignorable-vars*
    116            `((declare (ignorable ,@*ignorable-vars*))))
    117        ,@*arg-tests*
    118        (let* ,(nreverse *user-lets*)
    119          ,@declarations
     115                   ,@(when *ignorable-vars*
     116                       `((declare (ignorable ,@*ignorable-vars*))))
     117                   ,@*arg-tests*
     118                   (let* ,(nreverse *user-lets*)
     119                     ,@declarations
    120120                     ,@(if wrap-block
    121121                           `((block ,(fdefinition-block-name name) ,@forms))
    122122                           forms)))
    123     `(,@(when (and env-arg-name (not env-arg-used))
     123                `(,@(when (and env-arg-name (not env-arg-used))
    124124                      `((declare (ignore ,env-arg-name)))))
    125     documentation
    126     minimum
    127     maximum)))))
     125                documentation
     126                minimum
     127                maximum)))))
    128128
    129129(defun defmacro-error (problem name)
    … …  
    136136      ((null remaining)
    137137       (if (and unknown-keyword
    138     (not allow-other-keys)
    139     (not (lookup-keyword :allow-other-keys key-list)))
    140      (values :unknown-keyword (list unknown-keyword valid-keys))
    141      (values nil nil)))
     138                (not allow-other-keys)
     139                (not (lookup-keyword :allow-other-keys key-list)))
     140           (values :unknown-keyword (list unknown-keyword valid-keys))
     141           (values nil nil)))
    142142    (cond ((not (and (consp remaining) (listp (cdr remaining))))
    143      (return (values :dotted-list key-list)))
    144     ((null (cdr remaining))
    145      (return (values :odd-length key-list)))
    146     ((or (eq (car remaining) :allow-other-keys)
    147          (memql (car remaining) valid-keys))
    148      (push (car remaining) already-processed))
    149     (t
    150      (setq unknown-keyword (car remaining))))))
     143           (return (values :dotted-list key-list)))
     144          ((null (cdr remaining))
     145           (return (values :odd-length key-list)))
     146          ((or (eq (car remaining) :allow-other-keys)
     147               (memql (car remaining) valid-keys))
     148           (push (car remaining) already-processed))
     149          (t
     150           (setq unknown-keyword (car remaining))))))
    151151
    152152(defun lookup-keyword (keyword key-list)
    … …  
    169169(defun parse-defmacro-lambda-list
    170170       (lambda-list arg-list-name name error-kind error-fun
    171         &optional top-level env-illegal ;;env-arg-name
     171                    &optional top-level env-illegal ;;env-arg-name
    172172                    )
    173173  (let* ((path-0 (if top-level `(cdr ,arg-list-name) arg-list-name))
    … …  
    182182    ;; in lambda lists.
    183183    (when (and (do ((list lambda-list (cdr list)))
    184        ((atom list) nil)
    185     (when (eq (car list) '&WHOLE) (return t)))
    186          (not (eq (car lambda-list) '&WHOLE)))
     184                   ((atom list) nil)
     185                (when (eq (car list) '&WHOLE) (return t)))
     186               (not (eq (car lambda-list) '&WHOLE)))
    187187      (error "&Whole must appear first in ~S lambda-list." error-kind))
    188188    (do ((rest-of-args lambda-list (cdr rest-of-args)))
    189   ((atom rest-of-args)
    190   (cond ((null rest-of-args) nil)
    191          ;; Varlist is dotted, treat as &rest arg and exit.
    192          (t (push-let-binding rest-of-args path nil)
    193       (setq restp t))))
     189        ((atom rest-of-args)
     190        (cond ((null rest-of-args) nil)
     191               ;; Varlist is dotted, treat as &rest arg and exit.
     192               (t (push-let-binding rest-of-args path nil)
     193                  (setq restp t))))
    194194      (let ((var (car rest-of-args)))
    195   (cond ((eq var '&whole)
    196          (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
    197           (setq rest-of-args (cdr rest-of-args))
    198           (push-let-binding (car rest-of-args) arg-list-name nil))
    199          ((and (cdr rest-of-args) (consp (cadr rest-of-args)))
    200           (pop rest-of-args)
    201           (let* ((destructuring-lambda-list (car rest-of-args))
    202            (sub (gensym "WHOLE-SUBLIST")))
    203       (push-sub-list-binding
    204       sub arg-list-name destructuring-lambda-list
    205       name error-kind error-fun)
    206       (parse-defmacro-lambda-list
    207       destructuring-lambda-list sub name error-kind error-fun)))
    208          (t
    209           (defmacro-error "&WHOLE" name))))
    210         ((eq var '&environment)
    211          (cond (env-illegal
    212           (error "&ENVIRONMENT is not valid with ~S." error-kind))
    213          ((not top-level)
    214           (error "&ENVIRONMENT is only valid at top level of lambda list.")))
    215          (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
    216           (setq rest-of-args (cdr rest-of-args))
     195        (cond ((eq var '&whole)
     196               (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
     197                      (setq rest-of-args (cdr rest-of-args))
     198                      (push-let-binding (car rest-of-args) arg-list-name nil))
     199                     ((and (cdr rest-of-args) (consp (cadr rest-of-args)))
     200                      (pop rest-of-args)
     201                      (let* ((destructuring-lambda-list (car rest-of-args))
     202                             (sub (gensym "WHOLE-SUBLIST")))
     203                        (push-sub-list-binding
     204                        sub arg-list-name destructuring-lambda-list
     205                        name error-kind error-fun)
     206                        (parse-defmacro-lambda-list
     207                        destructuring-lambda-list sub name error-kind error-fun)))
     208                     (t
     209                      (defmacro-error "&WHOLE" name))))
     210              ((eq var '&environment)
     211               (cond (env-illegal
     212                      (error "&ENVIRONMENT is not valid with ~S." error-kind))
     213                     ((not top-level)
     214                      (error "&ENVIRONMENT is only valid at top level of lambda list.")))
     215               (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
     216                      (setq rest-of-args (cdr rest-of-args))
    217217                      (setq *env-var* (car rest-of-args)
    218218                            env-arg-used t))
    219          (t
    220           (defmacro-error "&ENVIRONMENT" name))))
    221         ((or (eq var '&rest) (eq var '&body))
    222          (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
    223           (setq rest-of-args (cdr rest-of-args))
    224           (setq restp t)
    225           (push-let-binding (car rest-of-args) path nil))
    226          ((and (cdr rest-of-args) (consp (cadr rest-of-args)))
    227           (pop rest-of-args)
    228           (setq restp t)
    229           (let* ((destructuring-lambda-list (car rest-of-args))
    230            (sub (gensym "REST-SUBLIST")))
    231       (push-sub-list-binding sub path destructuring-lambda-list
     219                     (t
     220                      (defmacro-error "&ENVIRONMENT" name))))
     221              ((or (eq var '&rest) (eq var '&body))
     222               (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
     223                      (setq rest-of-args (cdr rest-of-args))
     224                      (setq restp t)
     225                      (push-let-binding (car rest-of-args) path nil))
     226                     ((and (cdr rest-of-args) (consp (cadr rest-of-args)))
     227                      (pop rest-of-args)
     228                      (setq restp t)
     229                      (let* ((destructuring-lambda-list (car rest-of-args))
     230                             (sub (gensym "REST-SUBLIST")))
     231                        (push-sub-list-binding sub path destructuring-lambda-list
    232232                                               name error-kind error-fun)
    233       (parse-defmacro-lambda-list
    234       destructuring-lambda-list sub name error-kind error-fun)))
    235          (t
    236           (defmacro-error (symbol-name var) name))))
    237         ((eq var '&optional)
    238          (setq now-processing :optionals))
    239         ((eq var '&key)
    240          (setq now-processing :keywords)
    241          (setq rest-name (gensym "KEYWORDS-"))
    242          (push rest-name *ignorable-vars*)
    243          (setq restp t)
    244          (push-let-binding rest-name path t))
    245         ((eq var '&allow-other-keys)
    246          (setq allow-other-keys-p t))
    247         ((eq var '&aux)
    248          (setq now-processing :auxs))
    249         ((listp var)
    250          (case now-processing
    251     (:required
    252       (let ((sub-list-name (gensym "SUBLIST-")))
    253         (push-sub-list-binding sub-list-name `(car ,path) var
    254              name error-kind error-fun)
    255         (parse-defmacro-lambda-list var sub-list-name name
    256             error-kind error-fun))
    257       (setq path `(cdr ,path))
    258       (incf minimum)
    259       (incf maximum))
    260     (:optionals
    261       (when (> (length var) 3)
    262         (error "more than variable, initform, and suppliedp in &optional binding ~S"
     233                        (parse-defmacro-lambda-list
     234                        destructuring-lambda-list sub name error-kind error-fun)))
     235                     (t
     236                      (defmacro-error (symbol-name var) name))))
     237              ((eq var '&optional)
     238               (setq now-processing :optionals))
     239              ((eq var '&key)
     240               (setq now-processing :keywords)
     241               (setq rest-name (gensym "KEYWORDS-"))
     242               (push rest-name *ignorable-vars*)
     243               (setq restp t)
     244               (push-let-binding rest-name path t))
     245              ((eq var '&allow-other-keys)
     246               (setq allow-other-keys-p t))
     247              ((eq var '&aux)
     248               (setq now-processing :auxs))
     249              ((listp var)
     250               (case now-processing
     251                (:required
     252                  (let ((sub-list-name (gensym "SUBLIST-")))
     253                    (push-sub-list-binding sub-list-name `(car ,path) var
     254                                           name error-kind error-fun)
     255                    (parse-defmacro-lambda-list var sub-list-name name
     256                                                error-kind error-fun))
     257                  (setq path `(cdr ,path))
     258                  (incf minimum)
     259                  (incf maximum))
     260                (:optionals
     261                  (when (> (length var) 3)
     262                    (error "more than variable, initform, and suppliedp in &optional binding ~S"
    263263                           var))
    264       (push-optional-binding (car var) (cadr var) (caddr var)
    265           `(not (null ,path)) `(car ,path)
    266           name error-kind error-fun)
    267       (setq path `(cdr ,path))
    268       (incf maximum))
    269     (:keywords
    270       (let* ((keyword-given (consp (car var)))
    271       (variable (if keyword-given
    272                (cadar var)
    273                (car var)))
    274       (keyword (if keyword-given
    275               (caar var)
    276               (make-keyword variable)))
    277       (supplied-p (caddr var)))
    278         (push-optional-binding variable (cadr var) supplied-p
    279              `(keyword-supplied-p ',keyword
    280                 ,rest-name)
    281              `(lookup-keyword ',keyword
    282                   ,rest-name)
    283              name error-kind error-fun)
    284         (push keyword keys)))
    285     (:auxs (push-let-binding (car var) (cadr var) nil))))
    286         ((symbolp var)
    287          (case now-processing
    288     (:required
    289       (incf minimum)
    290       (incf maximum)
    291       (push-let-binding var `(car ,path) nil)
    292       (setq path `(cdr ,path)))
    293     (:optionals
    294       (incf maximum)
    295       (push-let-binding var `(car ,path) nil `(not (null ,path)))
    296       (setq path `(cdr ,path)))
    297     (:keywords
    298       (let ((key (make-keyword var)))
    299         (push-let-binding var `(lookup-keyword ,key ,rest-name)
    300               nil)
    301         (push key keys)))
    302     (:auxs
    303       (push-let-binding var nil nil))))
    304         (t
    305          (error "non-symbol in lambda-list: ~S" var)))))
     264                  (push-optional-binding (car var) (cadr var) (caddr var)
     265                                        `(not (null ,path)) `(car ,path)
     266                                        name error-kind error-fun)
     267                  (setq path `(cdr ,path))
     268                  (incf maximum))
     269                (:keywords
     270                  (let* ((keyword-given (consp (car var)))
     271                        (variable (if keyword-given
     272                                       (cadar var)
     273                                       (car var)))
     274                        (keyword (if keyword-given
     275                                      (caar var)
     276                                      (make-keyword variable)))
     277                        (supplied-p (caddr var)))
     278                    (push-optional-binding variable (cadr var) supplied-p
     279                                           `(keyword-supplied-p ',keyword
     280                                                                ,rest-name)
     281                                           `(lookup-keyword ',keyword
     282                                                            ,rest-name)
     283                                           name error-kind error-fun)
     284                    (push keyword keys)))
     285                (:auxs (push-let-binding (car var) (cadr var) nil))))
     286              ((symbolp var)
     287               (case now-processing
     288                (:required
     289                  (incf minimum)
     290                  (incf maximum)
     291                  (push-let-binding var `(car ,path) nil)
     292                  (setq path `(cdr ,path)))
     293                (:optionals
     294                  (incf maximum)
     295                  (push-let-binding var `(car ,path) nil `(not (null ,path)))
     296                  (setq path `(cdr ,path)))
     297                (:keywords
     298                  (let ((key (make-keyword var)))
     299                    (push-let-binding var `(lookup-keyword ,key ,rest-name)
     300                                      nil)
     301                    (push key keys)))
     302                (:auxs
     303                  (push-let-binding var nil nil))))
     304              (t
     305               (error "non-symbol in lambda-list: ~S" var)))))
    306306    ;; Generate code to check the number of arguments.
    307307    (push `(unless (<= ,minimum
    … …  
    328328                   (when ,problem
    329329                     ,(if (eq error-fun 'error)
    330         `(lambda-list-broken-key-list-error
     330                          `(lambda-list-broken-key-list-error
    331331                           :kind ',error-kind
    332332                           ,@(when name `(:name ',name))
    … …  
    346346  (let ((var (gensym "TEMP-")))
    347347    (push `(,variable
    348       (let ((,var ,path))
    349         (if (listp ,var)
    350       ,var
    351       ,(if (eq error-fun 'error)
    352            `(bogus-sublist-error
    353             :kind ',error-kind
    354             ,@(when name `(:name ',name))
    355             :object ,var
    356             :lambda-list ',object)
    357            `(,error-fun 'defmacro-bogus-sublist-error
    358             :kind ',error-kind
    359             ,@(when name `(:name ',name))
    360             :object ,var
    361             :lambda-list ',object)))))
    362     *system-lets*)))
     348            (let ((,var ,path))
     349              (if (listp ,var)
     350                  ,var
     351                  ,(if (eq error-fun 'error)
     352                       `(bogus-sublist-error
     353                                    :kind ',error-kind
     354                                    ,@(when name `(:name ',name))
     355                                    :object ,var
     356                                    :lambda-list ',object)
     357                       `(,error-fun 'defmacro-bogus-sublist-error
     358                                    :kind ',error-kind
     359                                    ,@(when name `(:name ',name))
     360                                    :object ,var
     361                                    :lambda-list ',object)))))
     362          *system-lets*)))
    363363
    364364(defun push-let-binding (variable path systemp &optional condition
    365           (init-form nil))
     365                                  (init-form nil))
    366366  (let ((let-form (if condition
    367           `(,variable (if ,condition ,path ,init-form))
    368           `(,variable ,path))))
     367                      `(,variable (if ,condition ,path ,init-form))
     368                      `(,variable ,path))))
    369369    (if systemp
    370   (push let-form *system-lets*)
    371   (push let-form *user-lets*))))
     370        (push let-form *system-lets*)
     371        (push let-form *user-lets*))))
    372372
    373373(defun push-optional-binding (value-var init-form supplied-var condition path
    374           name error-kind error-fun)
     374                                        name error-kind error-fun)
    375375  (unless supplied-var
    376376    (setq supplied-var (gensym "SUPPLIEDP-")))
    377377  (push-let-binding supplied-var condition t)
    378378  (cond ((consp value-var)
    379   (let ((whole-thing (gensym "OPTIONAL-SUBLIST-")))
    380      (push-sub-list-binding whole-thing
    381           `(if ,supplied-var ,path ,init-form)
    382           value-var name error-kind error-fun)
    383      (parse-defmacro-lambda-list value-var whole-thing name
    384                error-kind error-fun)))
    385   ((symbolp value-var)
    386   (push-let-binding value-var path nil supplied-var init-form))
    387   (t
    388   (error "Illegal optional variable name: ~S" value-var))))
     379        (let ((whole-thing (gensym "OPTIONAL-SUBLIST-")))
     380           (push-sub-list-binding whole-thing
     381                                  `(if ,supplied-var ,path ,init-form)
     382                                  value-var name error-kind error-fun)
     383           (parse-defmacro-lambda-list value-var whole-thing name
     384                                       error-kind error-fun)))
     385        ((symbolp value-var)
     386        (push-let-binding value-var path nil supplied-var init-form))
     387        (t
     388        (error "Illegal optional variable name: ~S" value-var))))
    389389
    390390(defmacro destructuring-bind (lambda-list arg-list &rest body)
    391391  (let* ((arg-list-name (gensym "ARG-LIST-")))
    392392    (multiple-value-bind (body local-decls)
    393   (parse-defmacro lambda-list arg-list-name body nil 'destructuring-bind
    394       :anonymousp t
     393        (parse-defmacro lambda-list arg-list-name body nil 'destructuring-bind
     394                        :anonymousp t
    395395                        :doc-string-allowed nil
    396396                        :wrap-block nil)
    397397      `(let ((,arg-list-name ,arg-list))
    398   ,@local-decls
    399   ,body))))
     398        ,@local-decls
     399        ,body))))
    400400
    401401;; Redefine SYS:MAKE-MACRO-EXPANDER to use PARSE-DEFMACRO.
    … …  
    415415(define-condition defmacro-lambda-list-bind-error (program-error)
    416416  ((kind :reader defmacro-lambda-list-bind-error-kind
    417   :initarg :kind)
     417        :initarg :kind)
    418418   (name :reader defmacro-lambda-list-bind-error-name
    419   :initarg :name
    420   :initform nil)))
     419        :initarg :name
     420        :initform nil)))
    421421
    422422(defun print-defmacro-ll-bind-error-intro (condition stream)
    423423  (if (null (defmacro-lambda-list-bind-error-name condition))
    424424      (format stream
    425         "Error while parsing arguments to ~A in ~S:~%"
    426         (defmacro-lambda-list-bind-error-kind condition)
    427         (condition-function-name condition))
     425              "Error while parsing arguments to ~A in ~S:~%"
     426              (defmacro-lambda-list-bind-error-kind condition)
     427              (condition-function-name condition))
    428428      (format stream
    429         "Error while parsing arguments to ~A ~S:~%"
    430         (defmacro-lambda-list-bind-error-kind condition)
    431         (defmacro-lambda-list-bind-error-name condition))))
     429              "Error while parsing arguments to ~A ~S:~%"
     430              (defmacro-lambda-list-bind-error-kind condition)
     431              (defmacro-lambda-list-bind-error-name condition))))
    432432
    433433(define-condition defmacro-bogus-sublist-error
    434       (defmacro-lambda-list-bind-error)
     434                  (defmacro-lambda-list-bind-error)
    435435  ((object :reader defmacro-bogus-sublist-error-object :initarg :object)
    436436   (lambda-list :reader defmacro-bogus-sublist-error-lambda-list
    437     :initarg :lambda-list))
     437                :initarg :lambda-list))
    438438  (:report
    439439   (lambda (condition stream)
    440440     (print-defmacro-ll-bind-error-intro condition stream)
    441441     (format stream
    442        "Bogus sublist:~%  ~S~%to satisfy lambda-list:~%  ~:S~%"
    443        (defmacro-bogus-sublist-error-object condition)
    444        (defmacro-bogus-sublist-error-lambda-list condition)))))
     442             "Bogus sublist:~%  ~S~%to satisfy lambda-list:~%  ~:S~%"
     443             (defmacro-bogus-sublist-error-object condition)
     444             (defmacro-bogus-sublist-error-lambda-list condition)))))
    445445
    446446
    … …  
    449449  ((argument :reader defmacro-ll-arg-count-error-argument :initarg :argument)
    450450   (lambda-list :reader defmacro-ll-arg-count-error-lambda-list
    451     :initarg :lambda-list)
     451                :initarg :lambda-list)
    452452   (minimum :reader defmacro-ll-arg-count-error-minimum :initarg :minimum)
    453453   (maximum :reader defmacro-ll-arg-count-error-maximum :initarg :maximum))
    … …  
    456456     (print-defmacro-ll-bind-error-intro condition stream)
    457457     (format stream
    458        "Invalid number of elements in:~%  ~:S~%~
    459        to satisfy lambda-list:~%  ~:S~%"
    460        (defmacro-ll-arg-count-error-argument condition)
    461        (defmacro-ll-arg-count-error-lambda-list condition))
     458             "Invalid number of elements in:~%  ~:S~%~
     459             to satisfy lambda-list:~%  ~:S~%"
     460             (defmacro-ll-arg-count-error-argument condition)
     461             (defmacro-ll-arg-count-error-lambda-list condition))
    462462     (cond ((null (defmacro-ll-arg-count-error-maximum condition))
    463       (format stream "Expected at least ~D"
    464         (defmacro-ll-arg-count-error-minimum condition)))
    465      ((= (defmacro-ll-arg-count-error-minimum condition)
    466          (defmacro-ll-arg-count-error-maximum condition))
    467       (format stream "Expected exactly ~D"
    468         (defmacro-ll-arg-count-error-minimum condition)))
    469      (t
    470       (format stream "Expected between ~D and ~D"
    471         (defmacro-ll-arg-count-error-minimum condition)
    472         (defmacro-ll-arg-count-error-maximum condition))))
     463            (format stream "Expected at least ~D"
     464                    (defmacro-ll-arg-count-error-minimum condition)))
     465           ((= (defmacro-ll-arg-count-error-minimum condition)
     466               (defmacro-ll-arg-count-error-maximum condition))
     467            (format stream "Expected exactly ~D"
     468                    (defmacro-ll-arg-count-error-minimum condition)))
     469           (t
     470            (format stream "Expected between ~D and ~D"
     471                    (defmacro-ll-arg-count-error-minimum condition)
     472                    (defmacro-ll-arg-count-error-maximum condition))))
    473473     (format stream ", but got ~D."
    474        (length (defmacro-ll-arg-count-error-argument condition))))))
     474             (length (defmacro-ll-arg-count-error-argument condition))))))
    475475
    476476(define-condition defmacro-lambda-list-broken-key-list-error
    477       (defmacro-lambda-list-bind-error)
     477                  (defmacro-lambda-list-bind-error)
    478478  ((problem :reader defmacro-ll-broken-key-list-error-problem
    479       :initarg :problem)
     479            :initarg :problem)
    480480   (info :reader defmacro-ll-broken-key-list-error-info :initarg :info))
    481481  (:report (lambda (condition stream)
    482        (print-defmacro-ll-bind-error-intro condition stream)
    483        (format stream
    484          (ecase
    485       (defmacro-ll-broken-key-list-error-problem condition)
    486            (:dotted-list
    487       "Keyword/value list is dotted: ~S")
    488            (:odd-length
    489       "Odd number of elements in keyword/value list: ~S")
    490            (:duplicate
    491       "Duplicate keyword: ~S")
    492            (:unknown-keyword
    493       "~{Unknown keyword: ~S; expected one of ~{~S~^, ~}~}"))
    494          (defmacro-ll-broken-key-list-error-info condition)))))
     482             (print-defmacro-ll-bind-error-intro condition stream)
     483             (format stream
     484                     (ecase
     485                        (defmacro-ll-broken-key-list-error-problem condition)
     486                       (:dotted-list
     487                        "Keyword/value list is dotted: ~S")
     488                       (:odd-length
     489                        "Odd number of elements in keyword/value list: ~S")
     490                       (:duplicate
     491                        "Duplicate keyword: ~S")
     492                       (:unknown-keyword
     493                        "~{Unknown keyword: ~S; expected one of ~{~S~^, ~}~}"))
     494                     (defmacro-ll-broken-key-list-error-info condition)))))
    495495|#

  • trunk/abcl/src/org/armedbear/lisp/digest.lisp

    r14582 r15569  
    4343  "Returned ASCIIfied representation of SHA256 digest of byte-based resource at PATHS-OR-STRINGs."
    4444  (unless (and (null (rest paths-or-strings))
    45          (pathnamep (first paths-or-strings)))
     45               (pathnamep (first paths-or-strings)))
    4646    (warn "Unaudited computation of cryptographic digest initiated.")) ;; TODO Need tests with some tool for verification
    4747  (let ((first (first paths-or-strings))

  • trunk/abcl/src/org/armedbear/lisp/disassemble.lisp

    r15280 r15569  
    174174(defun get-loaded-from (function)
    175175  (let* ((jfield (find "loadedFrom" (java:jcall "getDeclaredFields" (java:jclass "org.armedbear.lisp.Function"))
    176            :key 'java:jfield-name :test 'equal)))
     176                       :key 'java:jfield-name :test 'equal)))
    177177    (java:jcall "setAccessible" jfield java:+true+)
    178178    (java:jcall "get" jfield function)))
    … …  
    180180(defun set-loaded-from (function value)
    181181  (let* ((jfield (find "loadedFrom" (java:jcall "getDeclaredFields" (java:jclass "org.armedbear.lisp.Function"))
    182            :key 'java:jfield-name :test 'equal)))
     182                       :key 'java:jfield-name :test 'equal)))
    183183    (java:jcall "setAccessible" jfield java:+true+)
    184184    (java:jcall "set" jfield function value)))
    … …  
    187187(defun fasl-compiled-closure-class-bytes (function)
    188188  (let* ((loaded-from (get-loaded-from function))
    189   (class-name (subseq (java:jcall "getName" (java:jcall "getClass" function)) (length "org.armedbear.lisp.")))
    190   (url (if (not (eq (pathname-device loaded-from) :unspecific))
    191       ;; we're loading from a jar
    192       (java:jnew "java.net.URL"
    193            (namestring (make-pathname :directory (pathname-directory loaded-from)
    194                      :device (pathname-device loaded-from)
    195                      :name class-name :type "cls")))
    196       ;; we're loading from a fasl file
    197       (java:jnew "java.net.URL" (namestring (make-pathname :device (list loaded-from)
    198                        :name class-name :type "cls"))))))
     189        (class-name (subseq (java:jcall "getName" (java:jcall "getClass" function)) (length "org.armedbear.lisp.")))
     190        (url (if (not (eq (pathname-device loaded-from) :unspecific))
     191                  ;; we're loading from a jar
     192                  (java:jnew "java.net.URL"
     193                             (namestring (make-pathname :directory (pathname-directory loaded-from)
     194                                                               :device (pathname-device loaded-from)
     195                                                               :name class-name :type "cls")))
     196                  ;; we're loading from a fasl file
     197                  (java:jnew "java.net.URL" (namestring (make-pathname :device (list loaded-from)
     198                                                                       :name class-name :type "cls"))))))
    199199    (read-byte-array-from-stream (java:jcall "openStream" url))))
    200200

  • trunk/abcl/src/org/armedbear/lisp/do.lisp

    r11391 r15569  
    3535(defun do-do-body (varlist endlist decls-and-code bind step name block)
    3636  (let* ((inits ())
    37   (steps ())
    38   (L1 (gensym))
    39   (L2 (gensym)))
     37        (steps ())
     38        (L1 (gensym))
     39        (L2 (gensym)))
    4040    ;; Check for illegal old-style do.
    4141    (when (or (not (listp varlist)) (atom endlist))
    … …  
    4444    (dolist (v varlist)
    4545      (cond ((symbolp v) (push v inits))
    46       ((listp v)
    47        (unless (symbolp (first v))
    48          (error "~S step variable is not a symbol: ~S" name (first v)))
    49        (case (length v)
    50          (1 (push (first v) inits))
    51          (2 (push v inits))
    52          (3 (push (list (first v) (second v)) inits)
    53       (setq steps (list* (third v) (first v) steps)))
    54          (t (error "~S is an illegal form for a ~S varlist." v name))))
    55       (t (error "~S is an illegal form for a ~S varlist." v name))))
     46            ((listp v)
     47             (unless (symbolp (first v))
     48               (error "~S step variable is not a symbol: ~S" name (first v)))
     49             (case (length v)
     50               (1 (push (first v) inits))
     51               (2 (push v inits))
     52               (3 (push (list (first v) (second v)) inits)
     53                  (setq steps (list* (third v) (first v) steps)))
     54               (t (error "~S is an illegal form for a ~S varlist." v name))))
     55            (t (error "~S is an illegal form for a ~S varlist." v name))))
    5656    ;; Construct the new form.
    5757    (multiple-value-bind (code decls) (parse-body decls-and-code nil)

  • trunk/abcl/src/org/armedbear/lisp/dotimes.java

    r15552 r15569  
    153153        thread.resetSpecialBindings(mark);
    154154        ext.inactive = true;
    155   while (thread.envStack.pop() != ext) {};
     155        while (thread.envStack.pop() != ext) {};
    156156      }
    157157  }

  • trunk/abcl/src/org/armedbear/lisp/dribble.lisp

    r15541 r15569  
    5555  the dribble file, and quits logging."
    5656  (cond (pathname
    57   (let* ((new-dribble-stream
    58     (open pathname
    59            :direction :output
    60            :if-exists if-exists
    61            :if-does-not-exist :create))
    62     (new-standard-output
    63     (make-broadcast-stream *standard-output* new-dribble-stream))
    64     (new-error-output
    65     (make-broadcast-stream *error-output* new-dribble-stream))
    66     (new-standard-input
    67     (make-echo-stream *standard-input* new-dribble-stream)))
    68      (push (list *dribble-stream* *standard-input* *standard-output*
    69            *error-output*)
    70     *previous-dribble-streams*)
    71      (setf *dribble-stream* new-dribble-stream)
    72      (setf *standard-input* new-standard-input)
    73      (setf *standard-output* new-standard-output)
    74      (setf *error-output* new-error-output)
     57        (let* ((new-dribble-stream
     58                (open pathname
     59                       :direction :output
     60                       :if-exists if-exists
     61                       :if-does-not-exist :create))
     62                (new-standard-output
     63                (make-broadcast-stream *standard-output* new-dribble-stream))
     64                (new-error-output
     65                (make-broadcast-stream *error-output* new-dribble-stream))
     66                (new-standard-input
     67                (make-echo-stream *standard-input* new-dribble-stream)))
     68           (push (list *dribble-stream* *standard-input* *standard-output*
     69                       *error-output*)
     70                *previous-dribble-streams*)
     71           (setf *dribble-stream* new-dribble-stream)
     72           (setf *standard-input* new-standard-input)
     73           (setf *standard-output* new-standard-output)
     74           (setf *error-output* new-error-output)
    7575           ;; Starting a new internal REPL for dribbling
    7676           (loop do
    … …  
    8686                   (format *error-output* "~a~%" c)
    8787                   (error c)))))))
    88   ((null *dribble-stream*)
    89   (error "Not currently dribbling."))
    90   (t
    91   (let ((old-streams (pop *previous-dribble-streams*)))
    92      (close *dribble-stream*)
    93      (setf *dribble-stream* (first old-streams))
    94      (setf *standard-input* (second old-streams))
    95      (setf *standard-output* (third old-streams))
    96      (setf *error-output* (fourth old-streams)))))
     88        ((null *dribble-stream*)
     89        (error "Not currently dribbling."))
     90        (t
     91        (let ((old-streams (pop *previous-dribble-streams*)))
     92           (close *dribble-stream*)
     93           (setf *dribble-stream* (first old-streams))
     94           (setf *standard-input* (second old-streams))
     95           (setf *standard-output* (third old-streams))
     96           (setf *error-output* (fourth old-streams)))))
    9797  (values))

  • trunk/abcl/src/org/armedbear/lisp/ed.lisp

    r14106 r15569  
    4141the file system."
    4242  (dolist (fun *ed-functions*
    43      (error 'simple-error
    44       :format-control "Don't know how to ~S ~A"
    45       :format-arguments (list 'ed x)))
     43           (error 'simple-error
     44                  :format-control "Don't know how to ~S ~A"
     45                  :format-arguments (list 'ed x)))
    4646    (when (funcall fun x)
    4747      (return)))

  • trunk/abcl/src/org/armedbear/lisp/ensure-directories-exist.lisp

    r14173 r15569  
    3636(defun ensure-directories-exist (pathspec &key (verbose nil))
    3737  (let ((pathname (pathname pathspec))
    38   (created-p nil))
     38        (created-p nil))
    3939;;; CLHS: Function ENSURE-DIRECTORIES-EXIST "An error of type
    4040;;; file-error is signaled if the host, device, or directory part of
    … …  
    4444              (wild-pathname-p pathname :directory))
    4545      (error 'file-error
    46        :format-control "Bad place for a wild HOST, DEVICE, or DIRECTORY component."
    47        :pathname pathname))
     46             :format-control "Bad place for a wild HOST, DEVICE, or DIRECTORY component."
     47             :pathname pathname))
    4848    (let ((dir (pathname-directory pathname)))
    4949      (loop :for i :from 1 :upto (length dir)

  • trunk/abcl/src/org/armedbear/lisp/extensible-sequences-base.lisp

    r12516 r15569  
    1111
    1212(shadow '(ELT LENGTH COUNT "COUNT-IF" "COUNT-IF-NOT"
    13     "FIND" "FIND-IF" "FIND-IF-NOT"
    14     "POSITION" "POSITION-IF" "POSITION-IF-NOT"
    15     "SUBSEQ" "COPY-SEQ" "FILL"
    16     "NSUBSTITUTE" "NSUBSTITUTE-IF" "NSUBSTITUTE-IF-NOT"
    17     "SUBSTITUTE" "SUBSTITUTE-IF" "SUBSTITUTE-IF-NOT"
    18     "REPLACE" "REVERSE" "NREVERSE" "REDUCE"
    19     "MISMATCH" "SEARCH"
    20     "DELETE" "DELETE-IF" "DELETE-IF-NOT"
    21     "REMOVE" "REMOVE-IF" "REMOVE-IF-NOT"
    22     "DELETE-DUPLICATES" "REMOVE-DUPLICATES" "SORT" "STABLE-SORT"))
     13          "FIND" "FIND-IF" "FIND-IF-NOT"
     14          "POSITION" "POSITION-IF" "POSITION-IF-NOT"
     15          "SUBSEQ" "COPY-SEQ" "FILL"
     16          "NSUBSTITUTE" "NSUBSTITUTE-IF" "NSUBSTITUTE-IF-NOT"
     17          "SUBSTITUTE" "SUBSTITUTE-IF" "SUBSTITUTE-IF-NOT"
     18          "REPLACE" "REVERSE" "NREVERSE" "REDUCE"
     19          "MISMATCH" "SEARCH"
     20          "DELETE" "DELETE-IF" "DELETE-IF-NOT"
     21          "REMOVE" "REMOVE-IF" "REMOVE-IF-NOT"
     22          "DELETE-DUPLICATES" "REMOVE-DUPLICATES" "SORT" "STABLE-SORT"))
    2323
    2424(export '(DOSEQUENCE
    25    
    26     MAKE-SEQUENCE-ITERATOR MAKE-SIMPLE-SEQUENCE-ITERATOR
    27    
    28     ITERATOR-STEP ITERATOR-ENDP ITERATOR-ELEMENT
    29     ITERATOR-INDEX ITERATOR-COPY
    30    
    31     WITH-SEQUENCE-ITERATOR WITH-SEQUENCE-ITERATOR-FUNCTIONS
    32    
    33     CANONIZE-TEST CANONIZE-KEY
    34    
    35     LENGTH ELT
    36     MAKE-SEQUENCE-LIKE ADJUST-SEQUENCE
    37      
    38     COUNT COUNT-IF COUNT-IF-NOT
    39     FIND FIND-IF FIND-IF-NOT
    40     POSITION POSITION-IF POSITION-IF-NOT
    41     SUBSEQ COPY-SEQ FILL
    42     NSUBSTITUTE NSUBSTITUTE-IF NSUBSTITUTE-IF-NOT
    43     SUBSTITUTE SUBSTITUTE-IF SUBSTITUTE-IF-NOT
    44     REPLACE REVERSE NREVERSE REDUCE
    45     MISMATCH SEARCH
    46     DELETE DELETE-IF DELETE-IF-NOT
    47     REMOVE REMOVE-IF REMOVE-IF-NOT
    48     DELETE-DUPLICATES REMOVE-DUPLICATES SORT STABLE-SORT))
     25         
     26          MAKE-SEQUENCE-ITERATOR MAKE-SIMPLE-SEQUENCE-ITERATOR
     27         
     28          ITERATOR-STEP ITERATOR-ENDP ITERATOR-ELEMENT
     29          ITERATOR-INDEX ITERATOR-COPY
     30         
     31          WITH-SEQUENCE-ITERATOR WITH-SEQUENCE-ITERATOR-FUNCTIONS
     32         
     33          CANONIZE-TEST CANONIZE-KEY
     34         
     35          LENGTH ELT
     36          MAKE-SEQUENCE-LIKE ADJUST-SEQUENCE
     37           
     38          COUNT COUNT-IF COUNT-IF-NOT
     39          FIND FIND-IF FIND-IF-NOT
     40          POSITION POSITION-IF POSITION-IF-NOT
     41          SUBSEQ COPY-SEQ FILL
     42          NSUBSTITUTE NSUBSTITUTE-IF NSUBSTITUTE-IF-NOT
     43          SUBSTITUTE SUBSTITUTE-IF SUBSTITUTE-IF-NOT
     44          REPLACE REVERSE NREVERSE REDUCE
     45          MISMATCH SEARCH
     46          DELETE DELETE-IF DELETE-IF-NOT
     47          REMOVE REMOVE-IF REMOVE-IF-NOT
     48          DELETE-DUPLICATES REMOVE-DUPLICATES SORT STABLE-SORT))
    4949
    5050;;; Adapted from SBCL
    … …  
    6767                     ,array-form)
    6868                   (if (typep ,sequence 'sequence)
    69            ,other-form
    70            (error 'type-error
    71             :datum ,sequence :expected-type 'sequence))))
     69                       ,other-form
     70                       (error 'type-error
     71                              :datum ,sequence :expected-type 'sequence))))
    7272             `((let ((,sequence (ext:truly-the vector ,sequence)))
    7373                 (declare (ignorable ,sequence))
    … …  
    8383  (let ((size (length sequence)))
    8484    (error "The bounding indices ~S and ~S are bad for a sequence of length ~S"
    85      start end size)))
     85           start end size)))
    8686
    8787(defun %set-elt (sequence index value)

  • trunk/abcl/src/org/armedbear/lisp/extensible-sequences.lisp

    r15544 r15569  
    986986  (defun filter-dolist-declarations (decls)
    987987    (mapcar (lambda (decl)
    988         `(declare ,@(remove-if
    989          (lambda (clause)
    990            (and (consp clause)
    991           (or (eq (car clause) 'type)
    992               (eq (car clause) 'ignore))))
    993          (cdr decl))))
    994       decls)))
     988              `(declare ,@(remove-if
     989                           (lambda (clause)
     990                             (and (consp clause)
     991                                  (or (eq (car clause) 'type)
     992                                      (eq (car clause) 'ignore))))
     993                           (cdr decl))))
     994            decls)))
    995995
    996996;; just like DOLIST, but with one-dimensional arrays
    … …  
    10131013
    10141014(defmacro sequence:dosequence ((e sequence &optional return &rest args &key
    1015           from-end start end) &body body)
     1015                                  from-end start end) &body body)
    10161016  (declare (ignore from-end start end))
    10171017  (multiple-value-bind (forms decls)

  • trunk/abcl/src/org/armedbear/lisp/fdefinition.lisp

    r15388 r15569  
    4848      (flet ((truename-no-error (p)
    4949               (if (and (pathnamep p)
    50       (not (and
    51             (stringp (pathname-device p))
    52             (string= (pathname-device p)
    53                "emacs-buffer")))
     50                        (not (and
     51                              (stringp (pathname-device p))
     52                              (string= (pathname-device p)
     53                                       "emacs-buffer")))
    5454                        (not (wild-pathname-p p)))
    5555                   (probe-file p)
    … …  
    131131      (setf source-position *source-position*))
    132132    (let ((source (if source-position
    133           (list source-pathname source-position)
    134           (list source-pathname))))
     133                      (list source-pathname source-position)
     134                      (list source-pathname))))
    135135      (let ((sym (if (consp name) (second name) name))
    136136            (new `(,type ,(if (symbolp (car source)) (car source) (namestring (car source))) ,(second source))))
    137137        (if (autoloadp 'delete)
    138    (put sym 'sys::source (cons new (get sym  'sys::source nil)))
     138         (put sym 'sys::source (cons new (get sym  'sys::source nil)))
    139139         (put sym 'sys::source (cons new (delete new (get sym  'sys::source nil)
    140140               :test (lambda(a b) (and (equalp (car a) (car b)) (equalp (second a) (second b) ))))))))))

  • trunk/abcl/src/org/armedbear/lisp/fill.lisp

    r12516 r15569  
    5555    (list-fill sequence item start end)
    5656    (cond ((and (stringp sequence)
    57     (zerop start)
    58     (null end))
    59      (simple-string-fill sequence item))
    60     (t
    61      (vector-fill sequence item start end)))
     57                (zerop start)
     58                (null end))
     59           (simple-string-fill sequence item))
     60          (t
     61           (vector-fill sequence item start end)))
    6262    (sequence:fill sequence item
    63        :start start
    64        :end (sequence::%check-generic-sequence-bounds
    65       sequence start end))))
     63                   :start start
     64                   :end (sequence::%check-generic-sequence-bounds
     65                        sequence start end))))

  • trunk/abcl/src/org/armedbear/lisp/find-all-symbols.lisp

    r11391 r15569  
    3434(defun find-all-symbols (string)
    3535  (let ((string (string string))
    36   (res ()))
     36        (res ()))
    3737    (dolist (package (list-all-packages))
    3838      (multiple-value-bind (symbol status) (find-symbol string package)

  • trunk/abcl/src/org/armedbear/lisp/find.lisp

    r12516 r15569  
    3838(defmacro vector-locater-macro (sequence body-form return-type)
    3939  `(let ((incrementer (if from-end -1 1))
    40   (start (if from-end (1- (the fixnum end)) start))
    41   (end (if from-end (1- (the fixnum start)) end)))
     40        (start (if from-end (1- (the fixnum end)) start))
     41        (end (if from-end (1- (the fixnum start)) end)))
    4242     (declare (fixnum start end incrementer))
    4343     (do ((index start (+ index incrementer))
    44     ,@(case return-type (:position nil) (:element '(current))))
    45   ((= index end) ())
     44          ,@(case return-type (:position nil) (:element '(current))))
     45        ((= index end) ())
    4646       (declare (fixnum index))
    4747       ,@(case return-type
    48      (:position nil)
    49      (:element `((setf current (aref ,sequence index)))))
     48           (:position nil)
     49           (:element `((setf current (aref ,sequence index)))))
    5050       ,body-form)))
    5151
    5252(defmacro locater-test-not (item sequence seq-type return-type)
    5353  (let ((seq-ref (case return-type
    54        (:position
    55         (case seq-type
    56           (:vector `(aref ,sequence index))
    57           (:list `(pop ,sequence))))
    58        (:element 'current)))
    59   (return (case return-type
    60       (:position 'index)
    61       (:element 'current))))
     54                   (:position
     55                    (case seq-type
     56                      (:vector `(aref ,sequence index))
     57                      (:list `(pop ,sequence))))
     58                   (:element 'current)))
     59        (return (case return-type
     60                  (:position 'index)
     61                  (:element 'current))))
    6262    `(if test-not
    63   (if (not (funcall test-not ,item (sys::apply-key key ,seq-ref)))
    64        (return ,return))
    65   (if (funcall test ,item (sys::apply-key key ,seq-ref))
    66        (return ,return)))))
     63        (if (not (funcall test-not ,item (sys::apply-key key ,seq-ref)))
     64             (return ,return))
     65        (if (funcall test ,item (sys::apply-key key ,seq-ref))
     66             (return ,return)))))
    6767
    6868(defmacro vector-locater (item sequence return-type)
    6969  `(vector-locater-macro ,sequence
    70       (locater-test-not ,item ,sequence :vector ,return-type)
    71       ,return-type))
     70                        (locater-test-not ,item ,sequence :vector ,return-type)
     71                        ,return-type))
    7272
    7373(defmacro locater-if-test (test sequence seq-type return-type sense)
    7474  (let ((seq-ref (case return-type
    75        (:position
    76         (case seq-type
    77           (:vector `(aref ,sequence index))
    78           (:list `(pop ,sequence))))
    79        (:element 'current)))
    80   (return (case return-type
    81       (:position 'index)
    82       (:element 'current))))
     75                   (:position
     76                    (case seq-type
     77                      (:vector `(aref ,sequence index))
     78                      (:list `(pop ,sequence))))
     79                   (:element 'current)))
     80        (return (case return-type
     81                  (:position 'index)
     82                  (:element 'current))))
    8383    (if sense
    84   `(if (funcall ,test (sys::apply-key key ,seq-ref))
    85        (return ,return))
    86   `(if (not (funcall ,test (sys::apply-key key ,seq-ref)))
    87        (return ,return)))))
     84        `(if (funcall ,test (sys::apply-key key ,seq-ref))
     85             (return ,return))
     86        `(if (not (funcall ,test (sys::apply-key key ,seq-ref)))
     87             (return ,return)))))
    8888
    8989(defmacro vector-locater-if-macro (test sequence return-type sense)
    9090  `(vector-locater-macro ,sequence
    91       (locater-if-test ,test ,sequence :vector ,return-type ,sense)
    92       ,return-type))
     91                        (locater-if-test ,test ,sequence :vector ,return-type ,sense)
     92                        ,return-type))
    9393
    9494(defmacro vector-locater-if (test sequence return-type)
    … …  
    101101  `(if from-end
    102102       (do ((sequence (nthcdr (- (the fixnum (length sequence))
    103         (the fixnum end))
    104             (reverse (the list ,sequence))))
    105       (index (1- (the fixnum end)) (1- index))
    106       (terminus (1- (the fixnum start)))
    107       ,@(case return-type (:position nil) (:element '(current))))
    108      ((or (= index terminus) (null sequence)) ())
    109   (declare (fixnum index terminus))
    110   ,@(case return-type
    111        (:position nil)
    112        (:element `((setf current (pop ,sequence)))))
    113   ,body-form)
     103                                (the fixnum end))
     104                              (reverse (the list ,sequence))))
     105            (index (1- (the fixnum end)) (1- index))
     106            (terminus (1- (the fixnum start)))
     107            ,@(case return-type (:position nil) (:element '(current))))
     108           ((or (= index terminus) (null sequence)) ())
     109        (declare (fixnum index terminus))
     110        ,@(case return-type
     111             (:position nil)
     112             (:element `((setf current (pop ,sequence)))))
     113        ,body-form)
    114114       (do ((sequence (nthcdr start ,sequence))
    115       (index start (1+ index))
    116       ,@(case return-type (:position nil) (:element '(current))))
    117      ((or (= index (the fixnum end)) (null sequence)) ())
    118   (declare (fixnum index))
    119   ,@(case return-type
    120        (:position nil)
    121        (:element `((setf current (pop ,sequence)))))
    122   ,body-form)))
     115            (index start (1+ index))
     116            ,@(case return-type (:position nil) (:element '(current))))
     117           ((or (= index (the fixnum end)) (null sequence)) ())
     118        (declare (fixnum index))
     119        ,@(case return-type
     120             (:position nil)
     121             (:element `((setf current (pop ,sequence)))))
     122        ,body-form)))
    123123
    124124(defmacro list-locater (item sequence return-type)
    125125  `(list-locater-macro ,sequence
    126            (locater-test-not ,item ,sequence :list ,return-type)
    127            ,return-type))
     126                       (locater-test-not ,item ,sequence :list ,return-type)
     127                       ,return-type))
    128128
    129129(defmacro list-locater-if-macro (test sequence return-type sense)
    130130  `(list-locater-macro ,sequence
    131            (locater-if-test ,test ,sequence :list ,return-type ,sense)
    132            ,return-type))
     131                       (locater-if-test ,test ,sequence :list ,return-type ,sense)
     132                       ,return-type))
    133133
    134134(defmacro list-locater-if (test sequence return-type)
    … …  
    146146
    147147(defun position (item sequence &rest args &key from-end (test #'eql) test-not
    148     (start 0) end key)
     148                (start 0) end key)
    149149  (sequence::seq-dispatch sequence
    150150    (list-position* item sequence from-end test test-not start end key)
    … …  
    213213
    214214(defun find (item sequence &rest args &key from-end (test #'eql) test-not
    215        (start 0) end key)
     215             (start 0) end key)
    216216  (let ((end (check-sequence-bounds sequence start end)))
    217217    (sequence::seq-dispatch sequence

  • trunk/abcl/src/org/armedbear/lisp/format.lisp

    r15124 r15569  
    106106(defmacro once-only (specs &body body)
    107107  (named-let frob ((specs specs)
    108        (body body))
     108                   (body body))
    109109             (if (null specs)
    110110                 `(progn ,@body)
    … …  
    128128;;; interpretation of the arguments is as follows:
    129129;;;
    130 ;;;     X - The floating point number to convert, which must not be
    131 ;;;   negative.
     130;;;     X       - The floating point number to convert, which must not be
     131;;;             negative.
    132132;;;     WIDTH    - The preferred field width, used to determine the number
    133 ;;;   of fraction digits to produce if the FDIGITS parameter
    134 ;;;   is unspecified or NIL. If the non-fraction digits and the
    135 ;;;   decimal point alone exceed this width, no fraction digits
    136 ;;;   will be produced unless a non-NIL value of FDIGITS has been
    137 ;;;   specified. Field overflow is not considerd an error at this
    138 ;;;   level.
     133;;;             of fraction digits to produce if the FDIGITS parameter
     134;;;             is unspecified or NIL. If the non-fraction digits and the
     135;;;             decimal point alone exceed this width, no fraction digits
     136;;;             will be produced unless a non-NIL value of FDIGITS has been
     137;;;             specified. Field overflow is not considerd an error at this
     138;;;             level.
    139139;;;     FDIGITS  - The number of fractional digits to produce. Insignificant
    140 ;;;   trailing zeroes may be introduced as needed. May be
    141 ;;;   unspecified or NIL, in which case as many digits as possible
    142 ;;;   are generated, subject to the constraint that there are no
    143 ;;;   trailing zeroes.
     140;;;             trailing zeroes may be introduced as needed. May be
     141;;;             unspecified or NIL, in which case as many digits as possible
     142;;;             are generated, subject to the constraint that there are no
     143;;;             trailing zeroes.
    144144;;;     SCALE    - If this parameter is specified or non-NIL, then the number
    145 ;;;   printed is (* x (expt 10 scale)). This scaling is exact,
    146 ;;;   and cannot lose precision.
     145;;;             printed is (* x (expt 10 scale)). This scaling is exact,
     146;;;             and cannot lose precision.
    147147;;;     FMIN     - This parameter, if specified or non-NIL, is the minimum
    148 ;;;   number of fraction digits which will be produced, regardless
    149 ;;;   of the value of WIDTH or FDIGITS. This feature is used by
    150 ;;;   the ~E format directive to prevent complete loss of
    151 ;;;   significance in the printed value due to a bogus choice of
    152 ;;;   scale factor.
     148;;;             number of fraction digits which will be produced, regardless
     149;;;             of the value of WIDTH or FDIGITS. This feature is used by
     150;;;             the ~E format directive to prevent complete loss of
     151;;;             significance in the printed value due to a bogus choice of
     152;;;             scale factor.
    153153;;;
    154154;;; Most of the optional arguments are for the benefit for FORMAT and are not
    … …  
    162162;;;     DIGIT-LENGTH    - The length of the string DIGIT-STRING.
    163163;;;     LEADING-POINT   - True if the first character of DIGIT-STRING is the
    164 ;;;          decimal point.
     164;;;                    decimal point.
    165165;;;     TRAILING-POINT  - True if the last character of DIGIT-STRING is the
    166 ;;;          decimal point.
     166;;;                    decimal point.
    167167;;;     POINT-POS       - The position of the digit preceding the decimal
    168 ;;;          point. Zero indicates point before first digit.
     168;;;                    point. Zero indicates point before first digit.
    169169;;;
    170170;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee
    … …  
    189189  (declare (ignore fmin)) ; FIXME
    190190  (cond ((zerop x)
    191   ;; Zero is a special case which FLOAT-STRING cannot handle.
    192   (if fdigits