Commit 46fbd9cd authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

2.32.22: better strcat and UIOP utilities for strings.

Some test script tweaks.
parent e24c1db0
Loading
Loading
Loading
Loading
+1 −1
Original line number Diff line number Diff line
@@ -74,7 +74,7 @@
  :licence "MIT"
  :description "Another System Definition Facility"
  :long-description "ASDF builds Common Lisp software organized into defined systems."
  :version "2.32.21" ;; to be automatically updated by make bump-version
  :version "2.32.22" ;; to be automatically updated by make bump-version
  :depends-on ()
  #+asdf3 :encoding #+asdf3 :utf-8
  ;; For most purposes, asdf itself specially counts as a builtin system.
+1 −1
Original line number Diff line number Diff line
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 2.32.21: Another System Definition Facility.
;;; This is ASDF 2.32.22: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
+4 −5
Original line number Diff line number Diff line
@@ -25,13 +25,13 @@ usage () {

unset DEBUG_ASDF_TEST upgrade clean_load load_systems test_interactively extract_all
SHELL=/bin/sh
export SHELL
export SHELL DEBUG_ASDF_TEST GCL_ANSI ASDF_OUTPUT_TRANSLATIONS

while getopts "cdtHulhu" OPTION
do
    case $OPTION in
        d)
            export DEBUG_ASDF_TEST=t
            DEBUG_ASDF_TEST=t
            ;;
        u)
            upgrade=t
@@ -183,12 +183,12 @@ case "$lisp" in
    flags="-norc -eval (ext::install-bytecodes-compiler)"
    eval="-eval" ;;
  gcl)
    export GCL_ANSI=t
    GCL_ANSI=t
    command="${GCL:-gcl}"
    flags="-batch"
    eval="-eval" ;;
  gclcvs)
    export GCL_ANSI=t
    GCL_ANSI=t
    command="${GCLCVS:-gclcvs}"
    flags="-batch"
    eval="-eval" ;;
@@ -332,7 +332,6 @@ run_upgrade_tests () {
    mkdir -p build/results/
    rm -f build/*.*f* uiop/*.*f* test/*.*f* ## Remove stale FASLs from ASDF 1.x, especially when different implementations have same name
    ASDF_OUTPUT_TRANSLATIONS="(:output-translations (\"${ASDFDIR}\" (\"${ASDFDIR}/build/fasls/\" :implementation \"asdf/\")) (t (\"${ASDFDIR}/build/fasls/\" :implementation \"root/\")) :ignore-inherited-configuration)"
    export ASDF_OUTPUT_TRANSLATIONS
    su=test/script-support.lisp
    for tag in `upgrade_tags` ; do
        for method in `upgrade_methods` ; do
+1 −1
Original line number Diff line number Diff line
@@ -135,11 +135,11 @@
    asdf/lisp-action:try-recompiling
    ;; types
    asdf/bundle:user-system
    #+sbcl uiop/lisp-build:sb-grovel-unknown-constant-condition
    ;; on some implementations only
    asdf/bundle:bundle-system
    asdf/bundle:register-pre-built-system 
    asdf/bundle:static-library
    uiop/lisp-build:sb-grovel-unknown-constant-condition
    uiop/os:parse-file-location-info
    uiop/os:parse-windows-shortcut
    uiop/os:read-little-endian
+31 −2
Original line number Diff line number Diff line
@@ -18,7 +18,9 @@
   #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
   #:remove-plist-keys #:remove-plist-key ;; plists
   #:emptyp ;; sequences
   #:strcat #:first-char #:last-char #:split-string ;; strings
   #:+non-base-chars-exist-p+ ;; characters
   #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings
   #:first-char #:last-char #:split-string
   #:string-prefix-p #:string-enclosed-p #:string-suffix-p
   #:find-class* ;; CLOS
   #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
@@ -183,10 +185,37 @@ Returns two values: \(A B C\) and \(1 2 3\)."
    (or (null x) (and (vectorp x) (zerop (length x))))))


;;; Characters
(with-upgradability ()
  (defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char))))


;;; Strings
(with-upgradability ()
  (defun base-string-p (string)
    (declare (ignorable string))
    #.(or +non-base-chars-exist-p+ '(eq 'base-char (array-element-type string))))

  (defun strings-common-element-type (strings)
    #.(if +non-base-chars-exist-p+
          '(if (loop :for s :in strings :always (or (null s) (base-string-p s)))
            'base-char 'character)
          ''character))

  (defun reduce/strcat (strings &key key start end)
    "Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE"
    (when (or start end) (setf strings (subseq strings start end)))
    (when key (setf strings (mapcar key strings)))
    (loop :with output = (make-string (loop :for s :in strings :sum (length s))
                                      :element-type (strings-common-element-type strings))
          :for input :in strings
          :for pos = 0 :then (+ pos l)
          :for l = (length input)
          :do (replace output input :start1 pos)
          :finally (return output)))

  (defun strcat (&rest strings)
    (apply 'concatenate 'string strings))
    (reduce/strcat strings))

  (defun first-char (s)
    (and (stringp s) (plusp (length s)) (char s 0)))
Loading