util.tl


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56

;; Copyright (c) 2003-2009, Dr. Edmund Weitz. All rights reserved.
;; Copyright (c) 2023, Kaz Kylheku.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;;   * Redistributions of source code must retain the above copyright
;;     notice, this list of conditions and the following disclaimer.
;;
;;   * Redistributions in binary form must reproduce the above
;;     copyright notice, this list of conditions and the following
;;     disclaimer in the documentation and/or other materials
;;     provided with the distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package :tl-who-priv)

;; A string with N spaces - used by indentation.
(defmacro n-spaces (n) ^(usr:str ,n))

;; If the input is a symbol, convert it to a string by taking its
;; name. If it is a string, take it as is.
;; Then, if the *upcase-tokens-p* variable is true, convert the
;; string to upper case, unless it contains at least one upper case
;; letter already. Finally, return the string.
(defun maybe-upcase (symbol)
  (let ((string (if (symbolp symbol)
                  (symbol-name symbol)
                  symbol)))
    (if (and *upcase-tokens-p* (not [find-if chr-isupper string]))
      (upcase-str string)
      string)))

;; Implement to ANSI CL's with-output-to-string (minus the element-type
;; keyword argument) argument using TXR Lisp's with-out-string-stream.
(defmacro with-output-to-string ((var : string-form) . body)
  (if (null string-form)
    ^(with-out-string-stream (,var) ,*body)
    (with-gensyms (str res)
      ^(let ((,str ,string-form) ,res)
         (string-extend ,str (with-out-string-stream (,var)
                               (set ,res (progn ,*body)))
                        t)
         ,res))))