Description: 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 --- 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: , Bug: Bug-Debian: https://bugs.debian.org/ Bug-Ubuntu: https://launchpad.net/bugs/ Forwarded: Reviewed-By: 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 || tpt_complex || tp