share/stringproc/stringproc.lisp

   1 ;;
   2 ;;                                  ~*~  STRINGPROC  ~*~
   3 ;;
   4 ;; Maxima string processing
   5 ;;
   6 ;; Copyright     : 2005-2016 Volker van Nek
   7 ;; Licence       : GPL2
   8 ;;
   9 ;; Test file     : rteststringproc.mac
  10 ;; Documentation : stringproc.texi
  11 ;;
  12
  13 #|
  14 Strings of length 1 are denoted as a Maxima character.
  15
  16 Position indices in strings are 1-indexed like in Maxima lists. This results to
  17 the following consistency.
  18
  19                charlist(str)[i] = charat(str, i), i >= 1.
  20 |#
  21
  22 (in-package :maxima)
  23
  24
  25 (declare-top (special *parse-utf-8-input*))
  26 #|
  27 In an application which encodes characters in UTF-8 and the external format of
  28 the Lisp reader is set to e.g. cp1252 (or has no format definition like in GCL)
  29 a string of length 1 which contains a non-us-ascii character like an umlaut
  30 is read as a sequence of two or more octets, e.g. auml -> #(195 164), and
  31 misinterpreted as a sequence of two or more characters.
  32
  33 When the flag *parse-utf-8-input* is set to true the string processing
  34 functions in stringproc.lisp and sregex.lisp decode and restructure octet
  35 sequences in a way that octet groups like '(195 164) are coded back into the
  36 original string of length 1.
  37
  38 In addition to this position indices in strings are fixed accordingly.
  39
  40 Functions like $alphacharp which need a Lisp character representation of a
  41 Maxima character do not work for non-us-ascii characters, e.g. auml is not
  42 recognized as alphabetic.
  43
  44 See comments to $adjust_external_format below for a detailed description.
  45 |#
  46
  47 ;; adjust the external format where necessary and possible
  48 ;;
  49 #-gcl (eval-when (:load-toplevel :execute)
  50   ;;
  51   #+ (and clisp (not unix))
  52     (when (boundp 'maxima::$wxplot_size)
  53       (setf custom:*terminal-encoding*
  54         (ext:make-encoding :charset (symbol-name :utf-8) :line-terminator :dos) ))
  55 )
  56
  57 ;; find the right value for *parse-utf-8-input*
  58 ;;
  59 (defun init-*parse-utf-8-input* ()
  60   #+unix
  61   (progn
  62     #+gcl t
  63     #-(or gcl) nil
  64     )
  65   #-unix (progn
  66     #+gcl (boundp 'maxima::$wxplot_size)  ;; we are in wxMaxima
  67     #+ccl nil
  68     #- (or ccl gcl)
  69       (and (boundp 'maxima::$wxplot_size) ;; we are in wxMaxima and
  70            (not (search "UTF"             ;; the external format is not utf-8 (e.g. SBCL)
  71                         (format nil "~s" (stream-external-format *standard-output*))
  72                         :test 'string-equal ))) ))
  73
  74 (defvar *parse-utf-8-input*
  75   (init-*parse-utf-8-input*)
  76   "Maxima itself parses the utf-8 input." )
  77
  78
  79 ;; when *parse-utf-8-input* is t read raw bytes according to the default external format
  80 ;;
  81 (defun string-to-raw-bytes (str)
  82   (intl::string-to-octets str #+cmucl :iso8859-1 ;; GNU/Linux terminal             ;; should not be needed
  83                               #-cmucl :cp1252 )) ;; wxMaxima on Windows (GCL,SBCL) ;; CLISP: should not be needed
  84                                                  ;; and GCL in GNU/Linux (GCL ignores encoding arg)
  85
  86
  87 ;; Setting this flag to true saves Maxima from parsing UTF-8 encoding.
  88 ;;   (If possible adjusting the external format should be preferred.)
  89 ;;
  90 (defvar $us_ascii_only nil "Promise to use only US-ASCII characters.")
  91 ;;
  92 (putprop '$us_ascii_only 'set-*parse-utf-8-input* 'assign)
  93 ;;
  94 (defun set-*parse-utf-8-input* (assign-var arg)
  95   (declare (ignore assign-var))
  96   (setq *parse-utf-8-input*
  97     (if arg nil (init-*parse-utf-8-input*)) ))
  98
  99
 100 ;; -------------------------------------------------------------------------- ;;
 101 ;; frequently used error messages:
 102
 103 (defun io-error (name which)
 104   (gf-merror (intl:gettext "`~m': ~m argument must be a stream.") name which) )
 105
 106 (defun s-error1 (name which)
 107   (gf-merror (intl:gettext "`~m': ~m argument must be a string.") name which) )
 108
 109 (defun s-error2 (name which)
 110   (gf-merror (intl:gettext "`~m': ~m arguments must be strings.") name which) )
 111
 112 (defun s-pos-error1 (name pos)
 113   (gf-merror (intl:gettext "`~m': unsuitable position index ~m") name pos) )
 114
 115 (defun s-pos-error2 (name)
 116   (gf-merror (intl:gettext "`~m': unsuitable start or end position.") name) )
 117 ;; -------------------------------------------------------------------------- ;;
 118
 119
 120 ;;  1. I/O
 121 ;;  2. characters
 122 ;;  3. strings
 123
 124
 125 ;; -------------------------------------------------------------------------- ;;
 126 ;;  1. I/O
 127
 128
 129 ;; $openw_binary, $opena_binary, $openr_binary
 130 ;;    are placed in share/numercalio/numercalio.lisp.
 131
 132
 133 (defun $openw (file &optional enc)
 134   #+gcl (declare (ignore enc))
 135   (unless (stringp file) (s-error1 "openw" "the"))
 136   (open file
 137         :direction :output
 138         #-gcl :external-format #-gcl (get-encoding enc "openw")
 139         :if-exists :supersede
 140         :if-does-not-exist :create ))
 141
 142
 143 (defun $opena (file &optional enc)
 144   #+gcl (declare (ignore enc))
 145   (unless (stringp file) (s-error1 "opena" "the"))
 146   #+gcl (open file :direction :output :if-exists :append :if-does-not-exist :create)
 147   #-gcl (let (encoding-to-use inferred-encoding encoding-from-argument)
 148           (declare (ignorable inferred-encoding encoding-from-argument))
 149           (if enc
 150             (setq encoding-to-use (setq encoding-from-argument (get-encoding enc "opena")))
 151             (progn
 152               (setq inferred-encoding (unicode-sniffer file))
 153               (if inferred-encoding
 154                 (let ((checked-encoding (check-encoding inferred-encoding)))
 155                   (when (null checked-encoding)
 156                     (merror (intl:gettext "opena: inferred encoding ~M for file ~M is not recognized by this Lisp implementation.") inferred-encoding file))
 157                   (when (eq checked-encoding 'unknown)
 158                     (mtell (intl:gettext "opena: warning: I don't know how to verify encoding for this Lisp implementation."))
 159                     (mtell (intl:gettext "opena: warning: go ahead with inferred encoding ~M and hope for the best.") inferred-encoding))
 160                   (setq encoding-to-use inferred-encoding))
 161                 (setq encoding-to-use (setq encoding-from-argument (get-encoding enc "opena"))))))
 162           (open file :direction :output :if-exists :append :if-does-not-exist :create :external-format encoding-to-use)))
 163
 164
 165 (defun $openr (file &optional enc)
 166   #+gcl (declare (ignore enc))
 167   (unless (stringp file) (s-error1 "openr" "the"))
 168   (unless (probe-file file)
 169     (gf-merror (intl:gettext "`openr': file does not exist: ~m") file) )
 170   #+gcl (open file)
 171   #-gcl (let (encoding-to-use inferred-encoding encoding-from-argument)
 172           (declare (ignorable inferred-encoding encoding-from-argument))
 173           (if enc
 174             (setq encoding-to-use (setq encoding-from-argument (get-encoding enc "openr")))
 175             (progn
 176               (setq inferred-encoding (unicode-sniffer file))
 177               (if inferred-encoding
 178                 (let ((checked-encoding (check-encoding inferred-encoding)))
 179                   (when (null checked-encoding)
 180                     (merror (intl:gettext "openr: inferred encoding ~M for file ~M is not recognized by this Lisp implementation.") inferred-encoding file))
 181                   (when (eq checked-encoding 'unknown)
 182                     (mtell (intl:gettext "openr: warning: I don't know how to verify encoding for this Lisp implementation."))
 183                     (mtell (intl:gettext "openr: warning: go ahead with inferred encoding ~M and hope for the best.") inferred-encoding))
 184                   (setq encoding-to-use inferred-encoding))
 185                 (setq encoding-to-use (setq encoding-from-argument (get-encoding enc "openr"))))))
 186           (let ((s (open file :external-format encoding-to-use)))
 187             (when (eql (peek-char nil s nil) #+clisp #\ZERO_WIDTH_NO-BREAK_SPACE
 188                                              #+(or abcl sbcl) #\UFEFF
 189                                              #-(or clisp abcl sbcl) #\U+FEFF)
 190               (read-char s))
 191             s)))
 192
 193
 194 (defun $make_string_input_stream (str &optional (start 1) (end nil)) ;; use 1-indexing
 195   (unless (stringp str) (s-error1 "make_string_input_stream" "first"))
 196   (decf start)
 197   (when end (decf end))
 198   (or (ignore-errors
 199         (make-string-input-stream str start end) )
 200       (s-pos-error2 "make_string_input_stream") ))
 201
 202
 203 (defun $make_string_output_stream ()
 204   (make-string-output-stream) )
 205
 206
 207 ;; Ignore the :element-type keyword.
 208 ;; So we get the default here, namely :element-type character.
 209 ;;
 210 (defun $get_output_stream_string (stream)
 211   (unless (streamp stream) (io-error "get_output_stream_string" "the"))
 212   (get-output-stream-string stream) )
 213
 214
 215 (defun $close (stream)
 216   (unless (streamp stream) (io-error "close" "the"))
 217   (close stream))
 218
 219
 220 (defun $flush_output (stream)
 221   (unless (streamp stream) (io-error "flush_output" "the"))
 222   (not (finish-output stream)) ) ;; so $flush_output and $close both return t
 223
 224
 225 (defun $flength (stream)
 226   (unless (streamp stream) (io-error "flength" "the"))
 227   (file-length stream))
 228
 229
 230 (defun $fposition (stream &optional pos)
 231   (unless (streamp stream) (io-error "fposition" "first"))
 232   (or (ignore-errors
 233         (if pos
 234           (file-position stream (1- pos))     ;; set file-pos, return t   (or nil)
 235           (progn
 236             (setq pos (file-position stream)) ;; get file-pos, return pos (or nil)
 237             (when pos (1+ pos)) )))
 238       (s-pos-error1 "fposition" pos) ))
 239
 240
 241 (defun $readline (stream)
 242   (unless (streamp stream) (io-error "readline" "the"))
 243   (let ((line (read-line stream nil nil)))
 244     (if line line) ))
 245
 246
 247 (defun $readchar (stream)
 248   (unless (streamp stream) (io-error "readchar" "the"))
 249   (let ((lc (read-char stream nil nil)))
 250     (when lc (string lc)) ))
 251
 252
 253 (defun $readbyte (stream)
 254   (unless (and (streamp stream)
 255                (equal (stream-element-type stream) '(unsigned-byte 8)) )
 256     (gf-merror (intl:gettext "`readbyte': argument must be a binary stream.")) )
 257   (read-byte stream nil nil) )
 258
 259
 260 (defun $writebyte (i stream)
 261   (unless (and (streamp stream)
 262                (equal (stream-element-type stream) '(unsigned-byte 8)) )
 263     (gf-merror (intl:gettext "`writebyte': argument must be a binary stream.")) )
 264   (write-byte i stream) )
 265
 266
 267 (defun $freshline (&optional (stream))
 268   (and stream (not (streamp stream)) (io-error "freshline" "optional"))
 269   (fresh-line stream))
 270
 271
 272 (defun $newline (&optional (stream))
 273   (and stream (not (streamp stream)) (io-error "newline" "optional"))
 274   (terpri stream) )
 275
 276
 277 ;; $printf is in printf.lisp
 278
 279
 280 ;; -- get or set a suitable encoding (hopefully) ---------------------------- ;;
 281 ;;
 282 (defun get-encoding (enc name)
 283   (cond
 284     (enc ;; set encoding:
 285      (unless (stringp enc)
 286        (gf-merror (intl:gettext
 287                    "`~m': the optional second argument must be a string." ) name ))
 288
 289      ;; All Lisps must recognize :default, per CLHS.
 290      (when (string= enc "DEFAULT")
 291        (return-from get-encoding :default))
 292
 293      (setq enc (intern (string-upcase enc) :keyword))
 294      ;;
 295      #+ccl
 296      (progn
 297        #+unix enc
 298        #-unix
 299        (cond
 300          ((boundp 'maxima::$wxplot_size) enc)
 301          (t (is-ignored enc name "to get some help")
 302             :utf-8 )))
 303      ;;
 304      #+clisp
 305      (progn
 306        #+unix
 307        (ext:make-encoding :charset (symbol-name enc) :line-terminator :unix)
 308        #-unix
 309        (let ((ef (stream-external-format *standard-input*)))
 310          (cond
 311            ((search "UTF" (format nil "~s" ef) :test 'string-equal)
 312             (ext:make-encoding :charset (symbol-name enc) :line-terminator :dos) )
 313            (t (is-ignored enc name "to enable the encoding argument")
 314               ef))))
 315      ;;
 316      #+cmucl
 317      (progn
 318        #+unix
 319        (let ((ef (stream-external-format *standard-output*))) ;; input format remains 'default'
 320          (cond
 321            ((check-encoding enc) enc)
 322            (t (is-ignored enc name "to enable the encoding argument")
 323               ef)))
 324        #-unix
 325        enc)
 326      ;;
 327      #+gcl
 328      (format t "`~a': GCL ignores the argument ~s.~%" name
 329              (string-downcase (symbol-name enc)) )
 330      ;;
 331      #+sbcl
 332      (progn
 333        #+unix enc
 334        #-unix
 335        (let ((ef (stream-external-format *standard-input*)))
 336          (cond
 337            ((eq ef :cp1252)
 338             (is-ignored enc name "to enable the encoding argument")
 339             ef)
 340            (t enc))))
 341      ;;
 342      #-(or ccl clisp cmucl gcl sbcl)
 343      enc) ;; ECL and others
 344     ;;
 345     (t ;; get encoding:
 346      #+ (or ecl ccl gcl)
 347      :utf-8 ;; ignored by GCL
 348      #+sbcl
 349      sb-impl::*default-external-format*
 350      #+cmucl
 351      stream:*default-external-format*
 352      #-(or ecl ccl gcl sbcl cmucl)
 353      (stream-external-format *standard-output*))))
 354
 355
 356 (defun is-ignored (enc name adds)
 357   (format t "`~a': The argument ~s is ignored. Enter~%" name
 358     (string-downcase (symbol-name enc)) )
 359   (format t "adjust_external_format();~%~a.~%" adds) )
 360
 361
 362 ;; -- adjust the external format -------------------------------------------- ;;
 363 #|
 364 Linux/Unix:
 365
 366           terminal, GUI                Lisp reader            string_to_octets
 367 string_0 ----encode----> UTF-8-octets ----decode----> string_1 ----encode----> octets
 368
 369 wMaxima, Xmaxima and commonly used terminals read characters in UTF-8
 370 which means the characters are encoded as UTF-8-octets.
 371
 372 From the Lisp's point of view this is the external format of the input.
 373 Any Lisp reader should read and decode this input in UTF-8 too.
 374 Then all characters are read as they are entered in a GUI or terminal.
 375 string_0 is equal to string_1. This is necessary for all stringproc functions
 376 like e.g. cryptools.lisp/string_to_octets to work properly.
 377
 378 UTF-8 is the default external format for SBCL, CLISP, ECL, CCL and CMUCL(GUI).
 379
 380 GCL has no format definition and Maxima itself parses the UTF-8 octets.
 381
 382 By default CMUCL uses ISO8859-1 in a terminal. The format is changed to UTF-8
 383 when loading stringproc.lisp.
 384
 385 So in GNU/Linux adjust_external_format prints a message and does nothing.
 386
 387 Observations based on Maxima 5.37post from git (Feb 2016).
 388
 389 Windows:
 390
 391 Like in Linux the external format of the Lisp reader should meet the format
 392 used by the terminal resp. by the GUI.
 393
 394 If the terminal uses cp850 it should be set to cp1252 (or ISO-8859-1).
 395 The font should be set to true type. Both changes enable the full range of
 396 cp1252 (resp. ISO-8859-1) and are assumed in the following.
 397
 398 CCL(terminal) reads UTF-8 and the input from terminal is (assumed to be) ISO-8859-1.
 399   The UTF-8 reader misinterprets codepoints > 127. Adjustment needed.
 400   Switch to ISO-8859-1 via Lisp option in 'maxima.bat'.
 401   (CCL does not support cp1252. Both encodiings should be iso8859-1.)
 402
 403 CCL(wxMaxima) reads UTF-8 and the input from wxMaxima is UTF-8. Do nothing.
 404
 405 CLISP(terminal) reads cp1252 and the input is (assumed to be) cp1252. Do nothing.
 406
 407 CLISP(wxMaxima) reads cp1252 and the input is UTF-8.
 408   cp1252 is changed to to UTF-8 when loading stringproc.lisp. Nothing left to do.
 409
 410 GCL has no format definition. Input from terminal and wxMaxima is (assumed to be) cp1252. Do nothing.
 411
 412 SBCL(terminal) reads UCS-2LE and the input is UCS-2LE. Do nothing.
 413
 414 SBCL(wxMaxima) reads cp1252 but the input is UTF-8. Adjustment needed.
 415   Switch to UTF-8 via Lisp command in init file.
 416   Update (Maxima 5.40.0): SBCL(wxMaxima) reads UTF-8 and the input is UTF-8. Do nothing.
 417
 418 Observations based on Maxima 5.36.1(ccl), 5.37.2/5.40.0(clisp), 5.37.3(gcl),
 419 5.37.2/5.40.0(sbcl) in Windows 7.
 420
 421 TODO: Comments on Xmaxima in Windows.
 422 |#
 423
 424 (defun $adjust_external_format ()
 425   #+ccl
 426   (progn
 427     #+unix
 428     (format t "The external format is utf-8 and has not been changed.~%")
 429     #-unix
 430     (let ((ef (stream-external-format *standard-input*)))
 431       (format t "The external format is ~a and has not been changed.~%" ef)
 432       (unless (boundp 'maxima::$wxplot_size)
 433         (format t "Command line: The external format is settable by an option in~%~a~%"
 434                 (combine-path *maxima-prefix* "bin" "maxima.bat") )
 435         (format t "Change the line~%set lisp_options=~%to~%")
 436         (format t "set lisp_options=-K :iso-8859-1~%")
 437         (format t "(cp850 and cp1252 are not supported by CCL.)~%")
 438         (use-cp "iso-8859-1" 28591) )))
 439   ;;
 440   #+clisp
 441   (let ((ef (stream-external-format *standard-input*)))
 442     #-unix
 443     (cond
 444       ((search "UTF" (format nil "~s" ef) :test 'string-equal)
 445        (format t "The external format is ~a.~%and has not been changed.~%" ef) )
 446       ((boundp 'maxima::$wxplot_size)
 447        ;; this should not happen
 448        ;; format should be adjusted when loading stringproc.lisp
 449        (format t "The external format has been changed to ~a~%"
 450                (setf custom:*terminal-encoding*
 451                      (ext:make-encoding :charset (symbol-name :utf-8) :line-terminator :dos) ))
 452        (format t "for this session only. For a permanent change put the lines~%")
 453        (format t "(setf custom:*terminal-encoding*~%")
 454        (format t "  (ext:make-encoding :charset (symbol-name :utf-8) :line-terminator :dos) )~%")
 455        (format t "into the init file .clisprc in your home directory. ")
 456        (format t "The file is probably~%~a~%" (combine-path *maxima-tempdir* ".clisprc"))
 457        (setq *parse-utf-8-input* nil)
 458        t )
 459       (t
 460        (format t "The external format is ~a~%and has not been changed.~%" ef)
 461        (use-cp "cp1252" 1252) ))
 462     #+unix
 463     (format t "The external format is ~a~%and has not been changed.~%" ef) )
 464   ;;
 465   #+cmucl
 466   (let ((ef (stream-external-format *standard-output*))) ;; format of ..
 467     (cond ;; .. *standard-input* might be 'default'
 468       ((eq ef :utf-8)
 469        (format t "The external format is ~a~%and has not been changed.~%" ef) )
 470       (t ;; this should not happen
 471        ;; format should be adjusted when loading stringproc.lisp
 472        (format t "The external format has been changed to utf-8~%")
 473        (format t "for this session only. For a permanent change put the line~%")
 474        (format t "(stream:set-system-external-format :utf-8)~%")
 475        (format t "into the init file .cmucl-init in your home directory. ")
 476        (format t "The file is probably~%~a~%" (combine-path *maxima-tempdir* ".cmucl-init"))
 477        (setq *parse-utf-8-input* nil)
 478        (stream:set-system-external-format :utf-8) ))) ;; returns t
 479   ;;
 480   #+ecl
 481   (format t "The external format is ~a~%and has not been changed.~%"
 482           (stream-external-format *standard-input*) )
 483   ;;
 484   #+gcl
 485   (progn
 486     (format t "There is no settable external format.~%")
 487     #-unix
 488     (use-cp "cp1252" 1252) )
 489   ;;
 490   #+sbcl
 491   (let ((ef (stream-external-format *standard-input*)))
 492     (cond
 493       ((eq ef :cp1252)
 494        (let ((path (sb-impl::userinit-pathname))
 495              (cmd "(setf sb-impl::*default-external-format* :utf-8)") )
 496          (with-open-file (stream
 497                           path
 498                           :direction :output
 499                           :if-exists :append
 500                           :if-does-not-exist :create )
 501            (format stream "~a~%" cmd) )
 502          (format t "The external format is cp1252 and has not been changed.~%")
 503          (format t "The line~%~a~%has been appended to the init file~%~a~%" cmd path)
 504          (format t "Please restart Maxima to change the external format to utf-8.~%") ))
 505       (t
 506        (format t "The external format is ~a~%and has not been changed.~%" ef) )))
 507   ;;
 508   #-(or ccl clisp cmucl ecl gcl sbcl) ;; all others
 509     (format t "Please file a report if adjusting the external format seems necessary.~%") )
 510
 511
 512 (defun use-cp (name id)
 513   (format t "Command line: To change the terminal encoding to ~a insert a line~%" name)
 514   (format t "chcp ~a~%immediately below of '@echo off' in~%~s~%"
 515     id (combine-path *maxima-prefix* "bin" "maxima.bat") )
 516   (format t "and in the properties of the terminal window set the font to a true type font.~%") )
 517
 518
 519 ;; -------------------------------------------------------------------------- ;;
 520 ;; 2. characters
 521
 522 ;; A Maxima character is a string of length 1. (Lisp strings are Maxima strings.)
 523
 524
 525 ;; Check if object is a Maxima character.
 526 ;;
 527 (defun $charp (obj)
 528   (and (stringp obj)
 529        (= 1 (if *parse-utf-8-input* (utf-8-slength obj) (length obj)) )))
 530
 531
 532 ;; Convert a string of length 1 into a Lisp character.
 533 ;;
 534 (defun $lchar (mc) ;; at Maxima level only for testing
 535   (l-char mc) )
 536 ;;
 537 (defun l-char (mc)
 538   (unless (and (stringp mc) (= 1 (length mc)))
 539     (gf-merror "package stringproc: ~m cannot be converted into a Lisp character." mc) )
 540   (character mc) )
 541
 542
 543 ;; Convert a Lisp character into a string of length 1.
 544 ;;
 545 (defun $cunlisp (lc) ;; at Maxima level only for testing
 546   (unless (characterp lc)
 547     (gf-merror "cunlisp: argument must be a Lisp character") )
 548   (string lc) )
 549
 550
 551 ;; Check if object is a Lisp character.
 552 ;;
 553 (defun $lcharp (obj) (characterp obj)) ;; for testing only
 554
 555
 556 ;; Tests for Lisp characters at Maxima level (Lisp level functions see below).
 557 ;;
 558 ;;  These functions assume that we know what alphabetic characters are.
 559 ;;  If mc is a non-US-ASCII character and we don't have Unicode support
 560 ;;  i.e. *parse-utf-8-input* is t, an error is thrown via l-char.
 561 ;;
 562 (defun $constituent (mc)   (constituent (l-char mc)))
 563 (defun $alphanumericp (mc) (alphanumericp (l-char mc)))
 564 (defun $alphacharp (mc)    (alpha-char-p (l-char mc)))
 565 (defun $lowercasep (mc)    (lower-case-p (l-char mc)))
 566 (defun $uppercasep (mc)    (upper-case-p (l-char mc)))
 567 ;;
 568 (defun $digitcharp (mc)
 569   (let ((nr (char-int (l-char mc))))
 570     (and (> nr 47.) (< nr 58.)) ))
 571
 572
 573 ;; Maxima character <--> code point or character name
 574 ;;
 575 ;;  $cint returns the corresponding unicode code point.
 576 ;;  $ascii returns a Maxima us-ascii-character for code points < 128.
 577 ;;  $unicode returns a Maxima character for a given code point or name.
 578 ;;
 579 ;;  The conversion Maxima character to name is possible in clisp, ecl, sbcl
 580 ;;  via printf(false, "~@c", mc);
 581 ;;
 582 ;;  GCL:
 583 ;;    A non-ASCII-character is encoded in UTF-8 by wxMaxima or a Linux terminal.
 584 ;;    GCL just passes them through octet by octet. Process these octets.
 585 ;;
 586 ;;  CMUCL (Linux, wxMaxima):
 587 ;;    $cint recognizes 16 bit characters only.
 588 ;;    utf8_to_unicode(string_to_octets(mc)); works where $cint fails.
 589 ;;
 590 ;;  SBCL (Windows, wxMaxima):
 591 ;;    It is assumed that the external format has been adjusted to UTF-8.
 592 ;;
 593 (defun $cint (mc)
 594   (unless ($charp mc)
 595     (gf-merror (intl:gettext "`cint': argument must be a Maxima character.")) )
 596   (mc2int mc) )
 597 ;;
 598 (defun mc2int (mc)
 599   (if *parse-utf-8-input*
 600     (ignore-errors ;; arguments larger than 16 bit might cause errors
 601       (utf8-to-uc (coerce (string-to-raw-bytes mc) 'list)) )
 602     (char-code (character mc)) ))
 603 ;;
 604 (defun $ascii (int)
 605   (unless (and (integerp int) (< int 128.))
 606     (gf-merror (intl:gettext
 607       "`ascii': argument must be a non-negative integer less than 128.
 608 Please use `unicode' for code points larger than 127." )))
 609   (string (code-char int)) )
 610 ;;
 611 ;; Code points as arguments are not checked for validity.
 612 ;; Names as arguments work in clisp, ecl, sbcl.
 613 ;; In allegro, cmuc code points and names are limited to 16 bit.
 614 ;; abcl, ccl, gcl, lispworks: unicode(name) returns false.
 615 ;; octets_to_string(unicode_to_utf8(code_point)); often works where unicode(code_point) fails.
 616 ;;
 617 (defun $unicode (arg)
 618   (cond
 619     ((integerp arg)
 620       (ignore-errors ;; arguments larger than 16 bit might cause errors
 621         (if *parse-utf-8-input*
 622           (let ((ol (uc-to-utf8 arg)))
 623             (utf-8-m-char (length ol) ol) )
 624           (string (code-char arg)) )))
 625     ((stringp arg)
 626       (setq arg (concatenate 'string "#\\" ($ssubst "_" " " arg)))
 627       (let ((*standard-input* (make-string-input-stream arg)))
 628         (ignore-errors (string (eval (read)))) ))
 629     (t
 630       (gf-merror (intl:gettext
 631         "`unicode': argument must be a string or a non-negative integer." )))))
 632
 633 ;; Code point conversion utf-8 <--> unicode
 634 ;;
 635 (defun $utf8_to_unicode (utf8)
 636   (unless (listp utf8) (utf8_to_unicode-error))
 637   (utf8-to-uc (cdr utf8)) )
 638 ;;
 639 (defun $unicode_to_utf8 (uc)
 640   (unless (integerp uc)
 641     (gf-merror (intl:gettext "`unicode_to_utf8': argument must be a non-negative integer.")) )
 642   (cons '(mlist simp) (uc-to-utf8 uc)) )
 643 ;;
 644 (defun utf8_to_unicode-error ()
 645   (gf-merror (intl:gettext
 646     "`utf8_to_unicode': argument must be a list of octets representing a single character." )))
 647 ;;
 648 (defun utf8-to-uc (u) ;; u = utf8
 649   (let ((l (length u)))
 650     (cond
 651       ((= 1 l)
 652         (when (logbitp 7 (car u)) (utf8_to_unicode-error))
 653         (car u) )
 654       ((= 2 l)
 655         (unless (= (ldb (byte 3 5) (car u)) #b110) (utf8_to_unicode-error)) ;; check the first octet only
 656         (logior (ash (ldb (byte 5 0) (car u)) 6)
 657                 (ldb (byte 6 0) (cadr u)) ))
 658       ((= 3 l)
 659         (unless (= (ldb (byte 4 4) (car u)) #b1110) (utf8_to_unicode-error))
 660         (logior (ash (ldb (byte 4 0) (car u)) 12.)
 661                 (ash (ldb (byte 6 0) (cadr u)) 6.)
 662                 (ldb (byte 6 0) (caddr u)) ))
 663       ((= 4 l)
 664         (unless (= (ldb (byte 5 3) (car u)) #b11110) (utf8_to_unicode-error))
 665         (logior (ash (ldb (byte 3 0) (car u)) 18.)
 666                 (ash (ldb (byte 6 0) (cadr u)) 12.)
 667                 (ash (ldb (byte 6 0) (caddr u)) 6.)
 668                 (ldb (byte 6 0) (cadddr u)) ))
 669       (t (utf8_to_unicode-error)) )))
 670 ;;
 671 (defun uc-to-utf8 (uc) ;; uc = unicode
 672   (let (utf8)
 673     (cond
 674       ((< uc #x7f)
 675         (push uc utf8) )
 676       ((< uc #x7ff)
 677         (push (logior 128. (ldb (byte 6 0) uc)) utf8)
 678         (push (logior 192. (ldb (byte 5 6) uc)) utf8) )
 679       ((< uc #xffff)
 680         (dolist (i '(0 6))
 681           (push (logior 128. (ldb (byte 6 i) uc)) utf8) )
 682         (push (logior 224. (ldb (byte 4 12.) uc)) utf8) )
 683       (t
 684         (dolist (i '(0 6 12.))
 685           (push (logior 128. (ldb (byte 6 i) uc)) utf8) )
 686         (push (logior 240. (ldb (byte 3 18.) uc)) utf8) ))
 687     utf8 ))
 688
 689
 690 ;; Comparison - test functions - at Maxima level
 691 ;;
 692 (defun $cequal (mc1 mc2)
 693   (if *parse-utf-8-input*
 694     (= (mc2int mc1) (mc2int mc2))
 695     (char= (l-char mc1) (l-char mc2)) ))
 696 ;;
 697 (defun $clessp (mc1 mc2)
 698   (if *parse-utf-8-input*
 699     (< (mc2int mc1) (mc2int mc2))
 700     (char< (l-char mc1) (l-char mc2)) ))
 701 ;;
 702 (defun $cgreaterp (mc1 mc2)
 703   (if *parse-utf-8-input*
 704     (> (mc2int mc1) (mc2int mc2))
 705     (char> (l-char mc1) (l-char mc2)) ))
 706 ;;
 707 ;;  Ignoring case assumes alphabetic characters. But we can't check for
 708 ;;  non-US-ASCII alphabetic characters when we don't have Unicode support and
 709 ;;  *parse-utf-8-input* is t. Throw an error via l-char for non-US-ASCII chars.
 710 ;;
 711 (defun $cequalignore    (mc1 mc2)  (char-equal    (l-char mc1) (l-char mc2)))
 712 (defun $clesspignore    (mc1 mc2)  (char-lessp    (l-char mc1) (l-char mc2)))
 713 (defun $cgreaterpignore (mc1 mc2)  (char-greaterp (l-char mc1) (l-char mc2)))
 714
 715
 716 ;; Comparison - test functions - at Lisp level
 717 ;;
 718 (defun cequal          (c1 c2)  (char=         c1 c2)) ;; Lisp chars assumed
 719 (defun clessp          (c1 c2)  (char<         c1 c2))
 720 (defun cgreaterp       (c1 c2)  (char>         c1 c2))
 721 ;;
 722 (defun cequalignore    (c1 c2)  (char-equal    c1 c2))
 723 (defun clesspignore    (c1 c2)  (char-lessp    c1 c2))
 724 (defun cgreaterpignore (c1 c2)  (char-greaterp c1 c2))
 725
 726
 727 ;; Special Maxima characters
 728 ;;
 729 (defmvar $newline (string #\newline)
 730   "Maxima newline character"
 731   :setting-predicate #'(lambda (x)
 732                          (values (stringp x)
 733                                  "must be a string")))
 734
 735 (defmvar $tab (string #\tab)
 736   "Maxima tab character"
 737   :setting-predicate #'(lambda (x)
 738                            (values (stringp x)
 739                                    "must be a string")))
 740
 741 (defmvar $space (string #\space)
 742   "Maxima space character"
 743   :setting-predicate #'(lambda (x)
 744                          (values (stringp x)
 745                                  "must be a string")))
 746
 747 (defun $tab () $tab) ;; returns Maxima tab character; can be autoloaded
 748
 749 ;; -------------------------------------------------------------------------- ;;
 750 ;; 3. strings
 751
 752 ;; Position indices in strings are 1-indexed, i.e.
 753 ;;
 754 ;;   charlist(str)[i] = charat(str, i), i >= 1.
 755
 756 ;; -------------------------------------------------------------------------- ;;
 757 ;; 3.0 tools for parsing UTF-8 encoded strings
 758 ;;
 759 ;; Remove the first n octets which form an UTF-8 character from a list of octets.
 760 ;; Values: 1. A reference to the rest of the list.
 761 ;;         2. The first n octets (we do not always need them).
 762 (defun rm-first-utf-8-char (ol) ;; ol is an octet list of utf-8 coded characters
 763   (let ((oct (car ol)))
 764     (if (logbitp 7 oct)
 765       (if (logbitp 6 oct)
 766         (if (logbitp 5 oct)
 767           (if (logbitp 4 oct)
 768             (values (cddddr ol) (firstn 4 ol))
 769             (values (cdddr ol) (firstn 3 ol)) )
 770           (values (cddr ol) (firstn 2 ol)) )
 771         (gf-merror (intl:gettext "error while encoding")) )
 772       (values (cdr ol) (firstn 1 ol)) )))
 773
 774 ;; Retrieve an UTF-8 character from a list of octets.
 775 (defun utf-8-m-char (len ol)
 776   (if (= len 1)
 777     (string (code-char (car ol)))
 778     (map-into (make-string len) #'code-char ol) ))
 779
 780
 781 ;; We want positions in numbers of characters (not just octets) to find the
 782 ;;   right position in a string.
 783 ;; utf-8-pos-dec returns the decrement we need to adjust.
 784 ;;   (string position = octet position - decrement)
 785 (defun utf-8-pos-dec (str pos)
 786   (do ((ov (string-to-raw-bytes str))
 787        (i 0 (1+ i))
 788        (n 0) )
 789       ((= i pos) n)
 790     (when (= (logand (aref ov i) 192.) 128.)
 791       (incf n) )))
 792
 793 ;; Fix start and end character positions according to given UTF-8 octets.
 794 (defun utf-8-fix-start-end (ov args) ;; args contain start and end positions.
 795   (let ((start (cadr args))
 796         (end (caddr args))
 797          inc )
 798     (setq inc (utf-8-pos-inc ov 0 start))
 799     (incf start inc)
 800     (rplaca (cdr args) start)
 801     (when end
 802       (incf end inc)
 803       (incf end (utf-8-pos-inc ov start end))
 804       (rplaca (cddr args) end) )
 805     args ))
 806
 807 ;; Compute the position increment we need to find the right octet position.
 808 ;;   (octet position = string position + increment)
 809 (defun utf-8-pos-inc (ov off pos) ;; begin to count at a given offset
 810   (do ((i off (1+ i))
 811        (pos0 pos)
 812         oct )
 813       ((= i pos) (- pos pos0))
 814     (setq oct (aref ov i))
 815     (when (and (logbitp 7 oct) (logbitp 6 oct))
 816       (if (logbitp 5 oct)
 817         (if (logbitp 4 oct)
 818           (incf pos 3)
 819           (incf pos 2) )
 820         (incf pos) ))))
 821
 822 ;; -------------------------------------------------------------------------- ;;
 823 ;; 3.1 functions for strings
 824
 825
 826 (defun $stringp (obj) (stringp obj))
 827
 828
 829 (defun $scopy (s)
 830   (unless (stringp s) (s-error1 "scopy" ""))
 831   (copy-seq s) )
 832
 833
 834 (defun $smake (n mc)
 835   (unless (integerp n)
 836     (gf-merror (intl:gettext "`smake': first argument must be an integer.")) )
 837   (unless ($charp mc)
 838     (gf-merror (intl:gettext "`smake': second argument must be a Maxima character.")) )
 839   (if *parse-utf-8-input*
 840     (reduce #'$sconcat (make-list n :initial-element mc))
 841     (make-string n :initial-element (character mc)) ))
 842
 843
 844 (defun $charat (str pos)
 845   (unless (stringp str) (s-error1 "charat" "first"))
 846   (let ((end pos))
 847     (decf pos)
 848     (or (ignore-errors
 849           (when *parse-utf-8-input*
 850             (let* ((ov (string-to-raw-bytes str))
 851                    (args (utf-8-fix-start-end ov (list nil pos end))) )
 852               (setq pos (cadr args)
 853                     end (caddr args) )))
 854           (subseq str pos end) )
 855       (s-pos-error1 "charat" (1+ pos)) )))
 856
 857
 858 (defun $charlist (str)
 859   (unless (stringp str) (s-error1 "charlist" ""))
 860   (let ((cl (coerce str 'list)))
 861     (cons '(mlist simp)
 862       (if *parse-utf-8-input* (utf-8-charlist cl) (mapcar #'string cl)) )))
 863 ;;
 864 (defun utf-8-charlist (cl)
 865   (do ((ol (mapcar #'char-code cl))
 866         ch m-chars )
 867       ((null ol) (nreverse m-chars))
 868     (multiple-value-setq (ol ch) (rm-first-utf-8-char ol))
 869     (push (utf-8-m-char (length ch) ch) m-chars) ))
 870
 871
 872 (putprop '$sexplode '$charlist 'alias)
 873
 874
 875 ;; $tokens is an interface to `tokens' by Paul Graham.
 876 ;;
 877 ;;   When *parse-utf-8-input* is t
 878 ;;     then aside from $charp the test functions recognize us-ascii characters only.
 879 ;;
 880 (defun $tokens (str &optional (test '$constituent))
 881   (unless (stringp str) (s-error1 "tokens" "first"))
 882   (setq test (stripdollar test))
 883   (unless (member test '(constituent alphanumericp alphacharp digitcharp
 884                          lowercasep uppercasep charp ))
 885     (gf-merror (intl:gettext "`tokens': optional second argument must be one of ~%
 886 constituent, alphanumericp, alphacharp, digitcharp, lowercasep, uppercasep, charp" )))
 887   (cons '(mlist simp) (tokens str test 0)) )
 888 ;;
 889 (defun tokens (str test start) ;; this is the original version by Paul Graham
 890                                ;;   (ANSI Common Lisp, 1996, page 67)
 891   (let ((pos1 (position-if test str :start start)))
 892     (when pos1
 893       (let ((pos2 (position-if #'(lambda (ch) (not (funcall test ch)))
 894                                str
 895                                :start pos1 )))
 896         (cons (subseq str pos1 pos2)
 897               (when pos2 (tokens str test pos2)) )))))
 898 ;;
 899 ;; test functions for $tokens on Lisp level:
 900 ;;
 901 (defun constituent (ch) ;; Paul Graham - ANSI Common Lisp, 1996, page 67
 902   (and (graphic-char-p ch)
 903        (not (char= ch #\  ))))
 904
 905 (defun alphacharp    (ch)  (alpha-char-p ch))
 906 (defun digitcharp    (ch)  (digit-char-p ch))
 907 (defun lowercasep    (ch)  (lower-case-p ch))
 908 (defun uppercasep    (ch)  (upper-case-p ch))
 909 (defun charp         (ch)  (characterp   ch))
 910 ;;     characterp    (ch)
 911 ;;     alphanumericp (ch)  no renaming needed
 912
 913
 914 ;; Split a string at an optional user defined delimiter string.
 915 ;; In case of a multiple delimiter string an optional flag may be set.
 916 ;;
 917 (defun $split (str &rest args)
 918   (unless (stringp str) (s-error1 "split" "first"))
 919   (let ((ds " ")        ;; delimiter string
 920         (multiple? t) ) ;; treat multiple occurencies of ds as one?
 921     (dolist (a args)
 922       (cond
 923         ((stringp a) (setq ds a))
 924         ((member a '(t nil)) (setq multiple? a))
 925         (t (gf-merror (intl:gettext "`split': unsuitable optional arguments."))) ))
 926     (if (string= ds "")
 927       ($charlist str)
 928       (cons '(mlist simp) (split str ds multiple?)) )))
 929 ;;
 930 (defun split (str ds &optional (multiple? t))
 931   (let ((pos1 (search ds str)))
 932     (if pos1
 933       (let ((ss (subseq str 0 pos1)) lst)
 934         (unless (and multiple? (string= ss ""))
 935           (push ss lst) )
 936         (do ((pos2 pos1) off)
 937             ((null pos2)
 938               (when (and multiple? (string= ss ""))
 939                 (push ss lst) )
 940               (nreverse lst) )
 941           (setq off (+ pos1 (length ds))
 942                 pos2 (search ds str :start2 off)
 943                 ss (subseq str off pos2)
 944                 pos1 pos2 )
 945           (unless (and multiple? (string= ss ""))
 946             (push ss lst) )))
 947       (list str) )))
 948
 949
 950 ;; $sconcat for lists
 951 ;;
 952 ;;   optional: insert a user defined delimiter string
 953 ;;
 954 (defun $simplode (li &optional (ds ""))
 955   (unless (listp li)
 956     (gf-merror (intl:gettext "`simplode': first argument must be a list.")) )
 957   (unless (stringp ds)
 958     (s-error1 "simplode" "optional second") )
 959   (setq li (cdr li))
 960   (cond
 961     ((null li)
 962       ($sconcat) )
 963     ((null (cdr li))
 964       ($sconcat (car li)) )
 965     ((string= ds "")
 966       (reduce #'$sconcat li) )
 967     (t
 968       (do (acc) (())
 969         (push ($sconcat (pop li)) acc)
 970         (when (null li)
 971           (return (reduce #'(lambda (s0 s1) (concatenate 'string s0 s1)) (nreverse acc) :initial-value "")))
 972         (push ds acc) ))))
 973
 974
 975 (defun $slength (str)
 976   (unless (stringp str) (s-error1 "slength" ""))
 977   (if *parse-utf-8-input* (utf-8-slength str) (length str)) )
 978 ;;
 979 ;; if we don't know the number of non-ascii characters, we have to count
 980 (defun utf-8-slength (str)
 981   (do* ((ov (string-to-raw-bytes str))
 982         (i 0 (1+ i))
 983         (n 0)
 984         (len (array-dimension ov 0)) )
 985        ((= i len) n)
 986     (when (/= (logand (aref ov i) 192.) 128.)
 987       (incf n) )))
 988
 989
 990 (defun $sposition (mc str)
 991   (unless (and (stringp mc)
 992                (= 1 (if *parse-utf-8-input* ($slength mc) (length mc))) )
 993     (gf-merror (intl:gettext
 994       "`sposition': first argument must be a Maxima character." )))
 995   (unless (stringp str)
 996     (s-error1 "sposition" "second") )
 997   (if *parse-utf-8-input*
 998     ($ssearch mc str)
 999     (let ((pos (position (character mc) str)))
1000       (when pos (1+ pos)) )))
1001
1002
1003 (defun $sreverse (str)
1004   (unless (stringp str) (s-error1 "sreverse" ""))
1005   (if *parse-utf-8-input* (utf-8-sreverse str) (reverse str)) )
1006 ;;
1007 (defun utf-8-sreverse (str)
1008   (do ((ol (mapcar #'char-code (coerce str 'list)))
1009         ch m-chars )
1010       ((null ol)
1011        (reduce #'(lambda (s0 s1) (concatenate 'string s0 s1)) m-chars :initial-value ""))
1012     (multiple-value-setq (ol ch) (rm-first-utf-8-char ol))
1013     (push (utf-8-m-char (length ch) ch) m-chars) ))
1014
1015
1016 (defun $substring (str start &optional (end nil))
1017   (unless (stringp str) (s-error1 "substring" "first"))
1018   (decf start)
1019   (when end (decf end))
1020   (or (ignore-errors
1021         (when *parse-utf-8-input*
1022           (let* ((ov (string-to-raw-bytes str))
1023                  (args (utf-8-fix-start-end ov (list nil start end))) )
1024             (setq start (cadr args)
1025                   end (caddr args) )))
1026         (subseq str start end) )
1027       (s-pos-error2 "substring") ))
1028
1029
1030 ;; comparison - test functions - at Maxima and Lisp level
1031 ;;
1032 ;;
1033 (defun $sequal       (s1 s2) (string= s1 s2))      ;; for the sake of efficiency
1034 (defun $sequalignore (s1 s2) (string-equal s1 s2)) ;;   omit checkings here
1035 ;;
1036 (defun $slessp    (s1 s2) (scompare s1 s2 "slessp"    '$sequal t   #'$clessp))
1037 (defun $sgreaterp (s1 s2) (scompare s1 s2 "sgreaterp" '$sequal nil #'$cgreaterp))
1038 ;;
1039 (defun $slesspignore    (s1 s2) (scompare s1 s2 "slesspignore"    '$sequalignore t   #'$clesspignore))
1040 (defun $sgreaterpignore (s1 s2) (scompare s1 s2 "sgreaterpignore" '$sequalignore nil #'$cgreaterpignore))
1041 ;;
1042 (defun scompare (s1 s2 name test lessp? ccomp)
1043   (unless (and (stringp s1) (stringp s2)) (s-error2 name "the two"))
1044   (let ((pos (mismatch s1 s2 :test test)))
1045     (cond
1046       ((or (not pos) (>= pos (length (if lessp? s2 s1)))) nil)
1047       ((>= pos (length (if lessp? s1 s2))) t)
1048       (t (apply ccomp (chars-to-compare s1 s2 pos))) )))
1049 ;;
1050 (defun chars-to-compare (s1 s2 pos)
1051   (let ((l1 1) (l2 1))
1052     (when *parse-utf-8-input*
1053       ;; When mismatch finds a pos somewhere in an utf-8 octet sequence
1054       ;;   we have to identify the beginning and the length.
1055       (while (= (logand (char-code (elt (subseq s1 pos (1+ pos)) 0)) 192.) 128.)
1056         (decf pos) ) ;; the beginning
1057       (setq l1 (parse-utf-8-header s1 pos) ;; the length
1058             l2 (parse-utf-8-header s2 pos) ))
1059     (list (subseq s1 pos (+ pos l1)) (subseq s2 pos (+ pos l2))) ))
1060 ;;
1061 (defun parse-utf-8-header (str start)
1062   ;; The position start is the beginning of an utf-8 octet sequence.
1063   ;; parse-utf-8-header then returns the length of this sequence.
1064   (let ((h (char-code (elt (subseq str start (1+ start)) 0))))
1065     (cond
1066       ((not (logbitp 7 h)) 1)
1067       ((= (ldb (byte 3 5) h) #b110) 2)
1068       ((= (ldb (byte 4 4) h) #b1110) 3)
1069       ((= (ldb (byte 5 3) h) #b11110) 4)
1070       (t (gf-merror (intl:gettext "`parse-utf-8-header': ~m is no utf-8 header") h)) )))
1071
1072
1073 (defun $smismatch (s1 s2 &optional (test '$sequal))
1074   (unless (and (stringp s1) (stringp s2)) (s-error2 "smismatch" "first two"))
1075   (unless (member test '($sequal $sequalignore))
1076     (gf-merror (intl:gettext
1077       "`smismatch': optional third argument must be `sequal' or `sequalignore'." )))
1078   (let ((pos (mismatch s1 s2 :test test)))
1079     (when pos
1080       (if *parse-utf-8-input*
1081         (- (1+ pos)
1082            (utf-8-pos-dec s1 (if (= pos (length s1)) pos (1+ pos))) )
1083         (1+ pos) ))))
1084
1085
1086 ;; searching
1087 ;;
1088 ;;   the optional args are test, start, end (see s-optional-args below)
1089 ;;
1090 (defun $ssearch (seq str &rest args)
1091   (unless (and (stringp seq) (stringp str)) (s-error2 "ssearch" "first two"))
1092   (setq args (s-optional-args "ssearch" str args))
1093   (or (ignore-errors
1094         (let ((pos (apply #'ssearch `(,seq ,str ,@args))))
1095           (if pos
1096             (if *parse-utf-8-input*
1097               (- (1+ pos) (utf-8-pos-dec str pos))
1098               (1+ pos) )
1099             (return-from $ssearch nil) )))
1100       (s-pos-error2 "ssearch") ))
1101 ;;
1102 (defun ssearch (seq str &optional (test '$sequal) (start 0) (end nil))
1103   (search seq str :test test :start2 start :end2 end) )
1104
1105
1106 ;; allow arbitrary order of the optional args test, start, end
1107 ;;  (where start is of course the first integer in sequence)
1108 ;;
1109 (defun s-optional-args (name str args)
1110   (let ((test '$sequal)
1111         (start 1)
1112         (end nil)
1113         (i 0) )
1114     (dolist (a args)
1115       (cond
1116         ((and (= i 0) (integerp a))               (setq start a i 1))
1117         ((and (= i 1) (or (integerp a) (null a))) (setq end   a i 2))
1118         ((member a '($sequal $sequalignore))      (setq test  a    ))
1119         (t (gf-merror (intl:gettext "~m: unsuitable optional arguments.") name)) ))
1120     (setq args (list test (1- start) (if end (1- end) nil)))
1121     (when *parse-utf-8-input*
1122       (or (ignore-errors
1123             (setq args
1124               (utf-8-fix-start-end (string-to-raw-bytes str) args) ))
1125           (s-pos-error2 name) ))
1126     args ))
1127
1128
1129 ;; functions for string manipulation
1130
1131
1132 (defun $ssubstfirst (new old str &rest args)
1133   (unless (every #'stringp `(,new ,old ,str))
1134     (s-error2 "ssubstfirst" "first three") )
1135   (setq args (s-optional-args "ssubstfirst" str args))
1136   (or (ignore-errors
1137         (apply #'ssubstfirst `(,new ,old ,str ,@args)) )
1138       (s-pos-error2 "ssubstfirst") ))
1139 ;;
1140 (defun ssubstfirst (new old str &optional (test '$sequal) (start 0) (end nil) (matched? nil))
1141   (let ((len (length old))
1142         (pos (if matched? start (search old str :test test :start2 start :end2 end))))
1143     (if (null pos)
1144       str
1145       (concatenate 'string (subseq str 0 pos) new (subseq str (+ pos len))) )))
1146
1147
1148 (defun $ssubst (new old str &rest args)
1149   (unless (every #'stringp `(,new ,old ,str))
1150     (s-error2 "ssubst" "first three") )
1151   (setq args (s-optional-args "ssubst" str args))
1152   (or (ignore-errors
1153         (apply #'ssubst `(,new ,old ,str ,@args)))
1154       (s-pos-error2 "ssubst") ))
1155 ;;
1156 (defun ssubst (new old str &optional (test '$sequal) (start 0) (end nil))
1157   (let ((pos nil) (n (length new)) (o (length old)))
1158     (while (setq pos (search old str :test test :start2 start :end2 end))
1159       (setq str (ssubstfirst new old str test pos end t)
1160             start (+ pos n)
1161             end (when end (- (+ end n) o))))
1162     str))
1163
1164
1165 (defun $sremovefirst (seq str &rest args)
1166   (unless (and (stringp seq) (stringp str))
1167     (s-error2 "sremovefirst" "first two") )
1168   (setq args (s-optional-args "sremovefirst" str args))
1169   (or (ignore-errors
1170         (apply #'sremovefirst `(,seq ,str ,@args)) )
1171       (s-pos-error2 "sremovefirst") ))
1172 ;;
1173 (defun sremovefirst (seq str &optional (test '$sequal) (start 0) (end nil))
1174   (let* ((len (length seq))
1175          (pos (search seq str :test test :start2 start :end2 end))
1176          (sq1 (subseq str 0 pos))
1177          (sq2 (if pos (subseq str (+ pos len)) "")) )
1178     (concatenate 'string sq1 sq2)))
1179
1180
1181 (defun $sremove (seq str &rest args)
1182   (unless (and (stringp seq) (stringp str)) (s-error2 "sremove" "first two"))
1183   (setq args (s-optional-args "sremove" str args))
1184   (or (ignore-errors
1185         (apply #'sremove `(,seq ,str ,@args)) )
1186       (s-pos-error2 "sremove") ))
1187 ;;
1188 (defun sremove (seq str &optional (test '$sequal) (start 0) (end nil))
1189   (let ((pos (search seq str :test test :start2 start :end2 end)))
1190     (do ()
1191         ((null pos) str)
1192       (setq str (sremovefirst seq str test pos end))
1193       (when end (decf end (length seq)))
1194       (setq pos (search seq str :test test :start2 pos :end2 end))  )))
1195
1196
1197 (defun $sinsert (seq str pos)
1198   (decf pos)
1199   (unless (and (stringp seq) (stringp str)) (s-error2 "sinsert" "first two"))
1200   (or (ignore-errors
1201         (when *parse-utf-8-input*
1202           (incf pos (utf-8-pos-inc (string-to-raw-bytes str) 0 pos)) )
1203         (let ((sq1 (subseq str 0 pos))
1204               (sq2 (subseq str pos)) )
1205           (concatenate 'string sq1 seq sq2) ))
1206       (s-pos-error1 "sinsert" (1+ pos)) ))
1207
1208
1209 (defun $ssort (str &optional (test '$clessp))
1210   (unless (stringp str) (s-error1 "ssort" "first"))
1211   (if *parse-utf-8-input*
1212     (unless (member test '($clessp $cgreaterp))
1213       (let ((alt #+gcl ""
1214                  #-gcl "and the external format is not adjusted to UTF-8" ))
1215         (gf-merror (intl:gettext
1216           "`ssort': when us_ascii_only is false ~a
1217 the optional second argument must be `clessp' or `cgreaterp'." ) alt )))
1218     (unless (member test '($clessp $cgreaterp $clesspignore $cgreaterpignore))
1219       (gf-merror (intl:gettext
1220         "`ssort': optional second argument must be one of ~%clessp[ignore], cgreaterp[ignore]" ))))
1221   (setq test (stripdollar test))
1222   (let ((copy (copy-seq str)))
1223     (if *parse-utf-8-input* (utf-8-ssort copy test) (stable-sort copy test)) ))
1224 ;;
1225 (defun utf-8-ssort (str &optional (test 'clessp))
1226   (setq test
1227     (if (equal test 'clessp) #'< #'> ))
1228   (do ((ol (coerce (string-to-raw-bytes str) 'list))
1229         utf8 code-pts )
1230       ((null ol)
1231        (let ((l (mapcar #'(lambda (n) ($unicode n)) (stable-sort code-pts test))))
1232          (reduce #'(lambda (s0 s1) (concatenate 'string s0 s1)) l :initial-value "")))
1233     (multiple-value-setq (ol utf8) (rm-first-utf-8-char ol))
1234     (push (utf8-to-uc utf8) code-pts) ))
1235
1236
1237 (defun $strim (seq str)
1238   (unless (and (stringp seq) (stringp str)) (s-error2 "strim" ""))
1239   (string-trim seq str) )
1240
1241 (defun $striml (seq str)
1242   (unless (and (stringp seq) (stringp str)) (s-error2 "striml" ""))
1243   (string-left-trim seq str) )
1244
1245 (defun $strimr (seq str)
1246   (unless (and (stringp seq) (stringp str)) (s-error2 "strimr" ""))
1247   (string-right-trim seq str) )
1248
1249
1250 (defun $supcase (str &optional (start 1) (end nil))
1251   (change-case str "supcase" #'string-upcase start end) )
1252
1253 (defun $sdowncase (str &optional (start 1) (end nil))
1254   (change-case str "sdowncase" #'string-downcase start end) )
1255
1256 (defun change-case (str name sfun start end)
1257   (unless (stringp str) (s-error1 name "first"))
1258   (decf start)
1259   (when end (decf end))
1260   (or (ignore-errors
1261         (if *parse-utf-8-input*
1262           (let* ((ov (string-to-raw-bytes str))
1263                  (args (utf-8-fix-start-end ov (list nil start end))) )
1264             (funcall sfun str :start (cadr args) :end (caddr args)) )
1265           (funcall sfun str :start start :end end) ))
1266       (s-pos-error2 name) ))
1267
1268
1269 (defun $sinvertcase (str &optional (start 1) (end nil))
1270   (unless (stringp str) (s-error1 "sinvertcase" "first"))
1271   (decf start)
1272   (when end (decf end))
1273   (or (ignore-errors
1274         (when *parse-utf-8-input*
1275           (let* ((ov (string-to-raw-bytes str))
1276                  (args (utf-8-fix-start-end ov (list nil start end))) )
1277             (setq start (cadr args)
1278                   end (caddr args) )))
1279         (let ((sq1 (subseq str 0 start))
1280               (sq2 (s-invert-case (subseq str start end)))
1281               (sq3 (if end (subseq str end) "")) )
1282           (concatenate 'string sq1 sq2 sq3) ))
1283       (s-pos-error2 "sinvertcase") ))
1284 ;;
1285 (defun s-invert-case (str)
1286   (concatenate 'string
1287     (mapcar #'(lambda (s) (c-invert-case (character s)))
1288             (coerce str 'list) )))
1289 ;;
1290 (defun c-invert-case (ch)
1291   (if (upper-case-p ch)
1292     (char-downcase ch)
1293     (char-upcase ch) ))
1294
1295 ;; -------------------------------------------------------------------------- ;;
1296