Blob Blame History Raw
Description: <short summary of the patch>
 TODO: Put a short summary on the line above and replace this paragraph
 with a longer explanation of this change. Complete the meta-information
 with other relevant fields (see below for details). To make it easier, the
 information below has been extracted from the changelog. Adjust it or drop
 it.
 .
 gcl (2.6.12-45) unstable; urgency=high
 .
   * pathnames1.11
Author: Camm Maguire <camm@debian.org>

---
The information above should follow the Patch Tagging Guidelines, please
checkout http://dep.debian.net/deps/dep3/ to learn about the format. Here
are templates for supplementary fields that you might want to add:

Origin: <vendor|upstream|other>, <url of original patch>
Bug: <url in upstream bugtracker>
Bug-Debian: https://bugs.debian.org/<bugnumber>
Bug-Ubuntu: https://launchpad.net/bugs/<bugnumber>
Forwarded: <no|not-needed|url proving that it has been forwarded>
Reviewed-By: <name and email of someone who approved the patch>
Last-Update: 2016-10-31

--- gcl-2.6.12.orig/cmpnew/gcl_lfun_list.lsp
+++ gcl-2.6.12/cmpnew/gcl_lfun_list.lsp
@@ -144,7 +144,7 @@
 (DEFSYSFUN 'SVREF "Lsvref" '(T T) 'T NIL NIL) 
 (DEFSYSFUN 'APPLY "Lapply" '(T T *) 'T NIL NIL) 
 (DEFSYSFUN 'DECODE-FLOAT "Ldecode_float" '(T) '(VALUES T T T) NIL NIL) 
-(DEFSYSFUN 'SUBST-IF-NOT "Lsubst_if_not" '(T T T *) 'T NIL NIL) 
+;(DEFSYSFUN 'SUBST-IF-NOT "Lsubst_if_not" '(T T T *) 'T NIL NIL)
 (DEFSYSFUN 'RPLACA "Lrplaca" '(T T) 'T NIL NIL) 
 (DEFSYSFUN 'SYMBOL-PLIST "Lsymbol_plist" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'WRITE-STRING "Lwrite_string" '(T *) 'T NIL NIL) 
@@ -210,7 +210,7 @@
 (DEFSYSFUN 'NSUBLIS "Lnsublis" '(T T *) 'T NIL NIL) 
 (DEFSYSFUN 'CHAR-NOT-EQUAL "Lchar_not_equal" '(T *) 'T NIL T) 
 (DEFSYSFUN 'MACRO-FUNCTION "Lmacro_function" '(T) 'T NIL NIL) 
-(DEFSYSFUN 'SUBST-IF "Lsubst_if" '(T T T *) 'T NIL NIL) 
+;(DEFSYSFUN 'SUBST-IF "Lsubst_if" '(T T T *) 'T NIL NIL)
 (DEFSYSFUN 'COMPLEXP "Lcomplexp" '(T) 'T NIL T) 
 (DEFSYSFUN 'READ-LINE "Lread_line" '(*) '(VALUES T T) NIL NIL) 
 (DEFSYSFUN 'MAX "Lmax" '(T *) 'T NIL NIL) 
@@ -232,7 +232,7 @@
 (DEFSYSFUN 'FLOAT "Lfloat" '(T *) 'T NIL NIL) 
 ;(DEFSYSFUN 'FIRST "Lcar" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'ROUND "Lround" '(T *) '(VALUES T T) NIL NIL) 
-(DEFSYSFUN 'SUBST "Lsubst" '(T T T *) 'T NIL NIL) 
+;(DEFSYSFUN 'SUBST "Lsubst" '(T T T *) 'T NIL NIL)
 (DEFSYSFUN 'UPPER-CASE-P "Lupper_case_p" '(T) 'T NIL T) 
 (DEFSYSFUN 'ARRAY-ELEMENT-TYPE "Larray_element_type" '(T) 'T NIL NIL) 
 (DEFSYSFUN 'ADJOIN "Ladjoin" '(T T *) 'T NIL NIL) 
--- gcl-2.6.12.orig/lsp/gcl_arraylib.lsp
+++ gcl-2.6.12/lsp/gcl_arraylib.lsp
@@ -262,8 +262,6 @@
 			  (static (staticp array))
                      &aux (fill-pointer (or fill-pointer (when (array-has-fill-pointer-p array) (fill-pointer array)))))
 
-  (declare (ignore element-type))
-
   (let ((x (if initial-contents-supplied-p
 	       (make-array new-dimensions
 		       :adjustable t
--- gcl-2.6.12.orig/lsp/gcl_iolib.lsp
+++ gcl-2.6.12/lsp/gcl_iolib.lsp
@@ -80,7 +80,7 @@
      0 l)))
 
 (defun get-string-input-stream-index (stream &aux (s (c-stream-object0 stream)))
-  (+ (fill-pointer s) (multiple-value-bind (a b) (array-displacement s) b)))
+  (+ (fill-pointer s) (multiple-value-bind (a b) (array-displacement s) (declare (ignore a)) b)))
 
 (defmacro with-input-from-string ((var string &key index (start 0) end) . body)
   (declare (optimize (safety 1)))
@@ -457,10 +457,10 @@
 		      if-exists iesp if-does-not-exist idnesp external-format)))
     (when (typep s 'stream) (c-set-stream-object1 s pf) s)))
 
-(defun load-pathname-exists (z)
-  (or (probe-file z)
-      (when *allow-gzipped-file*
-	(when (probe-file (string-concatenate (namestring z) ".gz"))
+(defun load-pathname-exists (z &aux (z (link-expand (namestring z))))
+  (cond ((eq (stat z) :file) z)
+	(*allow-gzipped-file*
+	 (when (eq (stat (string-concatenate (namestring z) ".gz")) :file)
 	  z))))
 
 (defun load-pathname (p print if-does-not-exist external-format
--- gcl-2.6.12.orig/lsp/gcl_listlib.lsp
+++ gcl-2.6.12/lsp/gcl_listlib.lsp
@@ -180,3 +180,34 @@
 (defmacro nth-value (n expr)
   (declare (optimize (safety 1)))
   `(nth ,n (multiple-value-list ,expr)))
+
+(eval-when (compile eval)
+
+  (defmacro repl-if (tc) `(labels ((l (tr &aux (k (if kf (funcall kf tr) tr)))
+				       (cond (,tc n)
+					     ((atom tr) tr)
+					     ((let* ((ca (car tr))(a (l ca))(cd (cdr tr))(d (l cd)))
+						(if (and (eq a ca) (eq d cd)) tr (cons a d)))))))
+			     (declare (ftype (function (t) t) l))
+			     (l tr))))
+
+(defun subst (n o tr &key key test test-not
+		&aux (kf (when key (coerce key 'function)))
+		(tf (when test (coerce test 'function)))
+		(ntf (when test-not (coerce test-not 'function))))
+  (declare (optimize (safety 1)))
+  (check-type key (or null function))
+  (check-type test (or null function))
+  (check-type test-not (or null function))
+  (repl-if (cond (tf (funcall tf o k))(ntf (not (funcall ntf o k)))((eql o k)))))
+
+(defun subst-if (n p tr &key key &aux (kf (when key (coerce key 'function))))
+  (declare (optimize (safety 1)))
+  (check-type p function)
+  (check-type key (or null function))
+  (repl-if (funcall p k)))
+(defun subst-if-not (n p tr &key key &aux (kf (when key (coerce key 'function))))
+  (declare (optimize (safety 1)))
+  (check-type p function)
+  (check-type key (or null function))
+  (repl-if (not (funcall p k)))))
--- gcl-2.6.12.orig/lsp/gcl_truename.lsp
+++ gcl-2.6.12/lsp/gcl_truename.lsp
@@ -23,7 +23,8 @@
   (check-type pd pathname-designator)
   (when (wild-pathname-p ns)
     (error 'file-error :pathname pd :format-control "Pathname is wild"))
-  (let* ((ns (ensure-dir-string (link-expand ns)))(ppd (pathname ns)))
+  (let* ((ns (ensure-dir-string (link-expand ns)))
+	 (ppd (if (eq (namestring pd) ns) pd (pathname ns))))
     (unless (or (zerop (length ns)) (stat ns))
       (error 'file-error :pathname ns :format-control "Pathname does not exist"))
     (let* ((d (pathname-directory ppd))
--- gcl-2.6.12.orig/o/list.d
+++ gcl-2.6.12/o/list.d
@@ -528,26 +528,26 @@ object x;
 		vs_check_push(x);
 }
 
-/*
-	Subst(new, tree) pushes
-	the result of substituting new in tree
-	onto vs.
-*/
-static void
-subst(new, tree)
-object new, tree;
-{
-	cs_check(new);
-
-	if (TEST(tree))
-		vs_check_push(new);
-	else if (type_of(tree) == t_cons) {
-		subst(new, tree->c.c_car);
-		subst(new, tree->c.c_cdr);
-		stack_cons();
-	} else
-		vs_check_push(tree);
-}
+/* /\* */
+/* 	Subst(new, tree) pushes */
+/* 	the result of substituting new in tree */
+/* 	onto vs. */
+/* *\/ */
+/* static void */
+/* subst(new, tree) */
+/* object new, tree; */
+/* { */
+/* 	cs_check(new); */
+
+/* 	if (TEST(tree)) */
+/* 		vs_check_push(new); */
+/* 	else if (type_of(tree) == t_cons) { */
+/* 		subst(new, tree->c.c_car); */
+/* 		subst(new, tree->c.c_cdr); */
+/* 		stack_cons(); */
+/* 	} else */
+/* 		vs_check_push(tree); */
+/* } */
 
 /* static object */
 /* subst1(object new, object tree) { */
@@ -1153,25 +1153,25 @@ LFD(Lrplacd)()
 	vs_popp;
 }
 
-@(defun subst (new old tree &key test test_not key)
-	saveTEST;
-@
-	protectTEST;
-	setupTEST(old, test, test_not, key);
-	subst(new, tree);
-	tree = vs_pop;
-        /* if (kf==identity && */
-	/*     tf==test_eql && */
-	/*     (is_imm_fixnum(item_compared) || */
-	/*      ({enum type tp=type_of(item_compared);tp>t_complex || tp<t_fixnum;}))) */
-	/*   tree=subst1qi(new,tree); */
-	/* else */
-	/*   tree=subst1(new,tree); */
-	restoreTEST;
-	@(return tree)
-@)
+/* @(defun subst (new old tree &key test test_not key) */
+/* 	saveTEST; */
+/* @ */
+/* 	protectTEST; */
+/* 	setupTEST(old, test, test_not, key); */
+/* 	subst(new, tree); */
+/* 	tree = vs_pop; */
+/*         /\* if (kf==identity && *\/ */
+/* 	/\*     tf==test_eql && *\/ */
+/* 	/\*     (is_imm_fixnum(item_compared) || *\/ */
+/* 	/\*      ({enum type tp=type_of(item_compared);tp>t_complex || tp<t_fixnum;}))) *\/ */
+/* 	/\*   tree=subst1qi(new,tree); *\/ */
+/* 	/\* else *\/ */
+/* 	/\*   tree=subst1(new,tree); *\/ */
+/* 	restoreTEST; */
+/* 	@(return tree) */
+/* @) */
 
-PREDICATE(Lsubst,Lsubst_if,Lsubst_if_not, 3)
+/* PREDICATE(Lsubst,Lsubst_if,Lsubst_if_not, 3) */
 
 
 @(defun nsubst (new old tree &key test test_not key)
@@ -1506,9 +1506,9 @@ gcl_init_list_function()
 	make_function("LDIFF", Lldiff);
 	make_function("RPLACA", Lrplaca);
 	make_function("RPLACD", Lrplacd);
-	make_function("SUBST", Lsubst);
-	make_function("SUBST-IF", Lsubst_if);
-	make_function("SUBST-IF-NOT", Lsubst_if_not);
+	/* make_function("SUBST", Lsubst); */
+	/* make_function("SUBST-IF", Lsubst_if); */
+	/* make_function("SUBST-IF-NOT", Lsubst_if_not); */
 	make_function("NSUBST", Lnsubst);
 	make_function("NSUBST-IF", Lnsubst_if);
 	make_function("NSUBST-IF-NOT", Lnsubst_if_not);