Moved VECTOR-PUSH-EXTENT into the core because it is needed early in the bytecodes compiler

contrib/ecl-cdb/ecl-help.lisp

@@ -18,7 +18,7 @@
 			     :element-type '(unsigned-byte 8)
 			     :initial-element 0))
 	 (stream (ext:make-sequence-output-stream
-		  vector :external-format #+unicode :utf-8 #-unicode :default)))
+		  vector :external-format :utf-8)))
     (with-standard-io-syntax
       (let ((si::*print-package* (find-package "CL")))
 	(write object :stream stream :pretty nil

contrib/ecl-curl/ecl-curl.lisp

@@ -111,7 +111,7 @@
      :input t 
      :output t
      :buffering :full
-     :external-format #+unicode :iso-8859-1 #-unicode :default)))
+     :external-format :iso-8859-1)))
 
 ;;;---------------------------------------------------------------------------
 ;;; URL handling.
@@ -250,9 +250,7 @@
              (progn
                (setf o (open file-name 
                               :direction :output :if-exists :supersede
-                              :external-format
+                              :external-format :latin-1))
-			      #-unicode :default
-			      #+unicode :latin-1))
                (if length
                    (let ((buf (make-array length
                                           :element-type

src/c/Makefile.in

@@ -62,7 +62,7 @@ OBJS	= main.o symbol.o package.o cons.o list.o\
 	typespec.o assignment.o \
 	predicate.o number.o\
 	num_pred.o num_arith.o num_co.o\
-	num_log.o num_rand.o array.o sequence.o cmpaux.o\
+	num_log.o num_rand.o array.o vector_push.o sequence.o cmpaux.o\
 	macros.o backq.o stacks.o \
 	time.o unixint.o\
 	mapfun.o multival.o hash.o format.o pathname.o\

src/c/cinit.d

@@ -78,22 +78,6 @@ cl_array_dimensions(cl_object array)
 	return funcall(2, @'ARRAY-DIMENSIONS', array);
 }
 
-extern cl_object
-cl_vector_push_extend(cl_narg narg, cl_object elt, cl_object vector, ...)
-{
-	cl_index fp;
-	if (narg != 2) {
-		FEerror("Too many arguments to interim cl_vector_push_extend (cinit.d)", 0);
-	}
-	fp = vector->vector.fillp;
-	if (fp < vector->vector.dim) {
-		vector->vector.fillp = fp+1;
-		vector->vector.self.t[fp+1] = elt;
-		@(return MAKE_FIXNUM(fp))
-	}
-	return funcall(3, @'VECTOR-PUSH-EXTEND', elt, vector);
-}
-
 extern cl_object
 si_find_relative_package(cl_narg narg, cl_object package, ...)
 {

src/c/read.d

@@ -1826,7 +1826,7 @@ ecl_invalid_character_p(int c)
 	@(return Ct)
 @)
 
-@(defun get_macro_character (c &optional (readtable ecl_current_readtable()))
+@(defun get_macro_character (c &optional readtable)
 	enum ecl_chattrib cat;
 	cl_object dispatch;
 @

src/c/string.d

@@ -896,38 +896,3 @@ nstring_case(cl_narg narg, cl_object fun, ecl_casefun casefun, cl_va_list ARGS)
 	}
 	@(return output);
 @)
-
-ecl_character
-ecl_string_push_extend(cl_object s, ecl_character c)
-{
-	switch(type_of(s)) {
-#ifdef ECL_UNICODE
-	case t_string:
-#endif
-	case t_base_string:
-		/* We use the fact that both string types are
-		   byte-compatible except for the data. */
-		if (s->base_string.fillp >= s->base_string.dim) {
-			cl_object other;
-			cl_index new_length;
-			if (!ECL_ADJUSTABLE_ARRAY_P(s))
-				FEerror("string-push-extend: the string ~S is not adjustable.",
-					1, s);
-			if (s->base_string.dim >= ADIMLIM)
-				FEerror("Can't extend the string.", 0);
-			new_length = 1 + s->base_string.dim + (s->base_string.dim / 2);
-			if (new_length > ADIMLIM)
-				new_length = ADIMLIM;
-			other = si_make_vector(cl_array_element_type(s),
-					       MAKE_FIXNUM(new_length), Ct,
-					       MAKE_FIXNUM(s->base_string.fillp),
-					       Cnil, MAKE_FIXNUM(0));
-			ecl_copy_subarray(other, 0, s, 0, s->base_string.fillp);
-			s = si_replace_array(s, other);
-		}
-		ecl_char_set(s, s->base_string.fillp++, c);
-		return c;
-	default:
-                FEwrong_type_nth_arg(@[vector-push-extend],1,s,@[string]);
-	}
-}

src/c/symbols_list.h

@@ -993,8 +993,8 @@ cl_symbols[] = {
 {"VARIABLE", CL_ORDINARY, NULL, -1, OBJNULL},
 {"VECTOR", CL_ORDINARY, ECL_NAME(cl_vector), -1, OBJNULL},
 {"VECTOR-POP", CL_ORDINARY, ECL_NAME(cl_vector_pop), 1, OBJNULL},
-{"VECTOR-PUSH", CL_ORDINARY, ECL_NAME(cl_vector_push), 2, OBJNULL},
+{"VECTOR-PUSH", CL_ORDINARY, cl_vector_push, 2, OBJNULL},
-{"VECTOR-PUSH-EXTEND", CL_ORDINARY, ECL_NAME(cl_vector_push_extend), -1, OBJNULL},
+{"VECTOR-PUSH-EXTEND", CL_ORDINARY, cl_vector_push_extend, -1, OBJNULL},
 {"VECTORP", CL_ORDINARY, cl_vectorp, 1, OBJNULL},
 {"WARN", CL_ORDINARY, NULL, -1, OBJNULL},
 {"WARNING", CL_ORDINARY, NULL, -1, OBJNULL},

src/c/symbols_list2.h

@@ -993,8 +993,8 @@ cl_symbols[] = {
 {"VARIABLE",NULL},
 {"VECTOR","ECL_NAME(cl_vector)"},
 {"VECTOR-POP","ECL_NAME(cl_vector_pop)"},
-{"VECTOR-PUSH","ECL_NAME(cl_vector_push)"},
+{"VECTOR-PUSH","cl_vector_push"},
-{"VECTOR-PUSH-EXTEND","ECL_NAME(cl_vector_push_extend)"},
+{"VECTOR-PUSH-EXTEND","cl_vector_push_extend"},
 {"VECTORP","cl_vectorp"},
 {"WARN",NULL},
 {"WARNING",NULL},

src/c/vector_push.d

@@ -0,0 +1,88 @@
+/* -*- mode: c; c-basic-offset: 8 -*- */
+/*
+    string.d -- String routines.
+*/
+/*
+    Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
+    Copyright (c) 1990, Giuseppe Attardi.
+    Copyright (c) 2001, Juan Jose Garcia Ripoll.
+
+    ECL is free software; you can redistribute it and/or
+    modify it under thep terms of the GNU Library General Public
+    License as published by the Free Software Foundation; either
+    version 2 of the License, or (at your option) any later version.
+
+    See file '../Copyright' for full details.
+*/
+
+
+#include <ecl/ecl.h>
+#include <ecl/internal.h>
+
+static cl_object
+extend_vector(cl_object v, cl_index amount)
+{
+	cl_object other;
+	cl_index new_length;
+	unlikely_if (!ECL_VECTORP(v)) {
+		FEwrong_type_nth_arg(@[vector-push-extend],1,v,@[vector]);
+	}
+	if (!ECL_ADJUSTABLE_ARRAY_P(v))
+		FEerror("vector-push-extend: the array ~S is not adjustable.",
+			1, v);
+	if (v->vector.dim >= ADIMLIM)
+		FEerror("Can't extend the array.", 0);
+	if (amount == 0)
+		amount = v->vector.dim / 2 + 1;
+	new_length = v->vector.dim + amount;
+	if (new_length > ADIMLIM)
+		new_length = ADIMLIM;
+	other = si_make_vector(cl_array_element_type(v),
+			       MAKE_FIXNUM(new_length), Ct,
+			       MAKE_FIXNUM(v->vector.fillp),
+			       Cnil, MAKE_FIXNUM(0));
+	ecl_copy_subarray(other, 0, v, 0, v->vector.fillp);
+	return si_replace_array(v, other);
+}
+
+ecl_character
+ecl_string_push_extend(cl_object s, ecl_character c)
+{
+	switch(type_of(s)) {
+#ifdef ECL_UNICODE
+	case t_string:
+#endif
+	case t_base_string:
+		/* We use the fact that both string types are
+		   byte-compatible except for the data. */
+		if (s->base_string.fillp >= s->base_string.dim) {
+			s = extend_vector(s, 0);
+		}
+		ecl_char_set(s, s->base_string.fillp++, c);
+		return c;
+	default:
+                FEwrong_type_nth_arg(@[vector-push-extend],1,s,@[string]);
+	}
+}
+
+cl_object
+cl_vector_push(cl_object value, cl_object v)
+{
+	cl_index f = fix(cl_fill_pointer(v));
+	if (f >= v->vector.dim) {
+		@(return Cnil);
+	} else {
+		ecl_aset1(v, v->vector.fillp, value);
+		@(return MAKE_FIXNUM(v->vector.fillp++));
+	}
+}
+
+@(defun vector-push-extend (value v &optional (extent MAKE_FIXNUM(0)))
+@
+	cl_index f = fix(cl_fill_pointer(v));
+	if (f >= v->vector.dim) {
+		v = extend_vector(v, ecl_to_size(extent));
+	}
+	ecl_aset1(v, v->vector.fillp, value);
+	@(return MAKE_FIXNUM(v->vector.fillp++));
+@)

src/cmp/sysfun.lsp

@@ -869,7 +869,7 @@
     make-array vector array-dimensions array-in-bounds-p array-row-major-index
     bit sbit bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1
     bit-andc2 bit-orc1 bit-orc2 bit-not
-    vector-push vector-push-extend vector-pop adjust-array
+    vector-pop adjust-array
     ;; assignment.lsp
     si::setf-definition
     ;; conditions.lsp

src/doc/help.lsp

@@ -3158,6 +3158,18 @@ being the N-th value.")
 (docfun vectorp function (x) "
 Returns T if X is a vector; NIL otherwise.")
 
+(docfun vector-push function (new-element vector) "
+Replaces ITEM for the element of VECTOR that is pointed to by the fill-pointer
+of VECTOR and then increments the fill-pointer by one.  Returns NIL if the new
+value of the fill-pointer becomes too large.  Otherwise, returns the new fill-
+pointer as the value.")
+
+(docfun vector-push-extend function (new-element vector &optional (extension 1)) "
+Replaces ITEM for the element of VECTOR that is pointed to by the fill-pointer
+of VECTOR and then increments the fill-pointer by one.  If the new value of
+the fill-pointer becomes too large, extends VECTOR for N more elements.
+Returns the new value of the fill-pointer.")
+
 (docfun when macro "(when test {form}*)" "
 If TEST evaluates to non-NIL, then evaluates FORMs and returns all values of
 the last FORM.  If not, simply returns NIL.")

src/h/external.h

@@ -1628,7 +1628,6 @@ extern ECL_API cl_object make_base_string_copy(const char *s);
 extern ECL_API cl_object ecl_cstring_to_base_string_or_nil(const char *s);
 extern ECL_API bool ecl_string_eq(cl_object x, cl_object y);
 extern ECL_API bool ecl_member_char(ecl_character c, cl_object char_bag);
-extern ECL_API ecl_character ecl_string_push_extend(cl_object s, ecl_character c);
 extern ECL_API bool ecl_fits_in_base_string(cl_object s);
 extern ECL_API ecl_character ecl_char(cl_object s, cl_index i);
 extern ECL_API ecl_character ecl_char_set(cl_object s, cl_index i, ecl_character c);
@@ -1873,6 +1872,12 @@ extern ECL_API cl_object ecl_alloc_adjustable_extended_string(cl_index l);
 #define si_coerce_to_extended_string cl_string
 #endif
 
+/* vector_push.d  */
+
+extern ECL_API ecl_character ecl_string_push_extend(cl_object s, ecl_character c);
+extern ECL_API cl_object cl_vector_push _ARGS((cl_object V1, cl_object V2));
+extern ECL_API cl_object cl_vector_push_extend _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));
+
 
 /**********************************************************************
  * FUNCTIONS GENERATED BY THE LISP COMPILER
@@ -1898,8 +1903,6 @@ extern ECL_API cl_object cl_bit_andc2 _ARGS((cl_narg narg, cl_object V1, cl_obje
 extern ECL_API cl_object cl_bit_orc1 _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));
 extern ECL_API cl_object cl_bit_orc2 _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));
 extern ECL_API cl_object cl_bit_not _ARGS((cl_narg narg, cl_object V1, ...));
-extern ECL_API cl_object cl_vector_push _ARGS((cl_object V1, cl_object V2));
-extern ECL_API cl_object cl_vector_push_extend _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));
 extern ECL_API cl_object cl_vector_pop(cl_object V1);
 extern ECL_API cl_object cl_adjust_array _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));
 

src/lsp/arraylib.lsp

@@ -259,42 +259,6 @@ RESULT is a bit-array."
   (bit-array-op boole-c1 bit-array bit-array result-bit-array))
 
 
-(defun vector-push (new-element vector)
-  "Args: (item vector)
-Replaces ITEM for the element of VECTOR that is pointed to by the fill-pointer
-of VECTOR and then increments the fill-pointer by one.  Returns NIL if the new
-value of the fill-pointer becomes too large.  Otherwise, returns the new fill-
-pointer as the value."
-  ;; FILL-POINTER asserts vector is a vector
-  (let* ((fp (fill-pointer vector))
-         (vector (truly-the vector vector)))
-    (declare (optimize (safety 0)))
-    (cond ((< fp (array-total-size vector))
-           (sys:aset vector fp new-element)
-           (sys:fill-pointer-set vector (truly-the ext:array-index (1+ fp)))
-	   fp)
-	  (t nil))))
-
-(defun vector-push-extend (new-element vector &optional (extension 1))
-  "Args: (item vector &optional (n (length vector)))
-Replaces ITEM for the element of VECTOR that is pointed to by the fill-pointer
-of VECTOR and then increments the fill-pointer by one.  If the new value of
-the fill-pointer becomes too large, extends VECTOR for N more elements.
-Returns the new value of the fill-pointer."
-  ;; FILL-POINTER asserts vector is a vector
-  (let* ((fp (fill-pointer vector))
-         (vector (truly-the vector vector)))
-    (declare (optimize (safety 0)))
-    (let ((d (array-total-size vector)))
-      (unless (< fp d)
-        (adjust-array vector
-                      (list (+ d (max extension (max d 4))))
-                      :element-type (array-element-type vector)
-                      :fill-pointer fp))
-      (sys:aset vector fp new-element)
-      (sys:fill-pointer-set vector (1+ fp))
-      fp)))
-
 (defun vector-pop (vector)
   "Args: (vector)
 Decrements the fill-pointer of VECTOR by one and returns the element pointed

src/lsp/seqlib.lsp

@@ -769,7 +769,7 @@ evaluates to NIL.  See STABLE-SORT."
 	predicate (si::coerce-to-function predicate))
   (if (listp sequence)
       (list-merge-sort sequence predicate key)
-      (quick-sort sequence 0 (truly-the fixnum (1- (length sequence))) predicate key)))
+      (quick-sort sequence 0 (truly-the fixnum (length sequence)) predicate key)))
 
 
 (defun list-merge-sort (l predicate key)
@@ -831,41 +831,26 @@ evaluates to NIL.  See STABLE-SORT."
 	   (function pred key)
 	   (optimize (safety 0))
 	   (si::c-local))
-  (if (< start end)
+  (if (<= end (truly-the fixnum (1+ start)))
-      (let* ((j (1+ end)))
+      seq
-	(declare (fixnum j))
+      (let* ((j start) (k end) (d (elt seq start)) (kd (funcall key d)))
-	(let* ((i start)
+            (declare (fixnum j k))
-	       (l (- end start))
+        (block outer-loop
-	       (l-half (ash l -1))
+          (loop (loop (decf k)
-	       (p (+ start l-half))
+                      (unless (< j k) (return-from outer-loop))
-	       (d (elt seq p))
+                      (when (funcall pred (funcall key (elt seq k)) kd)
-	       (kd (funcall key d)))
+                            (return)))
-	  (declare (fixnum i p l l-half))
+                (loop (incf j)
-	  (rotatef (elt seq p) (elt seq start))
+                      (unless (< j k) (return-from outer-loop))
-	  (block outer-loop
+                      (unless (funcall pred (funcall key (elt seq j)) kd)
-	    (loop
+                              (return)))
-	       (loop 
+                (let ((temp (elt seq j)))
-		  (unless (> (decf j) i) (return-from outer-loop))
+                  (setf (elt seq j) (elt seq k)
-		  (when (funcall pred 
+                        (elt seq k) temp))))
-				 (funcall key (elt seq j)) kd)
+        (setf (elt seq start) (elt seq j)
-		    (return)))
+              (elt seq j) d)
-	       (loop 
+        (quick-sort seq start j pred key)
-	      (unless (< (incf i) j) (return-from outer-loop))
+        (quick-sort seq (1+ j) end pred key))))
-		  (unless (funcall pred
-				   (funcall key (elt seq i)) kd)
-		    (return)))
-	       (rotatef (elt seq i) (elt seq j))))
-	  (setf (elt seq start) (elt seq j)
-		(elt seq j) d))
-	(if (< (truly-the fixnum (- j start))
-	       (truly-the fixnum (- end j)))
-	    (progn
-	      (quick-sort seq start (1- j) pred key)
-	      (quick-sort seq (1+ j) end pred key))
-	    (progn
-	      (quick-sort seq (1+ j) end pred key)
-	      (quick-sort seq start (1- j) pred key))))
-      seq))
 
 
 (defun stable-sort (sequence predicate &key key)