src/utils.lisp

   1 ;;; Copyright 2005 Manuel Odendahl
   2 ;;; Copyright 2005-2006 Edward Marco Baringer
   3 ;;; Copyright 2007 Attila Lendvai
   4 ;;; Copyright 2007 Red Daly
   5 ;;; Copyright 2007-2012 Vladimir Sedach
   6 ;;; Copyright 2008 Travis Cross
   7
   8 ;;; SPDX-License-Identifier: BSD-3-Clause
   9
  10 ;;; Redistribution and use in source and binary forms, with or
  11 ;;; without modification, are permitted provided that the following
  12 ;;; conditions are met:
  13
  14 ;;; 1. Redistributions of source code must retain the above copyright
  15 ;;; notice, this list of conditions and the following disclaimer.
  16
  17 ;;; 2. Redistributions in binary form must reproduce the above
  18 ;;; copyright notice, this list of conditions and the following
  19 ;;; disclaimer in the documentation and/or other materials provided
  20 ;;; with the distribution.
  21
  22 ;;; 3. Neither the name of the copyright holder nor the names of its
  23 ;;; contributors may be used to endorse or promote products derived
  24 ;;; from this software without specific prior written permission.
  25
  26 ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
  27 ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
  28 ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
  29 ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  30 ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
  31 ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
  32 ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
  33 ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  34 ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
  35 ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  36 ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  37 ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  38 ;;; POSSIBILITY OF SUCH DAMAGE.
  39
  40 (in-package #:parenscript)
  41
  42 (let ((cache (make-hash-table :test 'equal)))
  43   (defun encode-js-identifier (identifier)
  44     "Given a string, produces to a valid JavaScript identifier by
  45 following transformation heuristics case conversion. For example,
  46 paren-script becomes parenScript, *some-global* becomes SOMEGLOBAL."
  47     (when (and (not (string= identifier "[]"))
  48                (find #\[ identifier))
  49       (warn "Parenscript symbol ~A contains a literal array accessor.
  50 This compound naming convention is deprecated and will be removed!
  51 Use AREF, ELT, GETPROP, @, or CHAIN instead."
  52             identifier))
  53     (when (find #\. identifier)
  54       (warn "Parenscript symbol ~A contains one or more dot operators.
  55 This compound naming convention is deprecated and will be removed!
  56 Use GETPROP, @, or CHAIN instead."
  57             identifier))
  58     (or
  59      (gethash identifier cache)
  60      (setf
  61        (gethash identifier cache)
  62        (cond
  63           ((some (lambda (c) (find c "-*+!?#@%/=:<>^")) identifier)
  64             (let ((lowercase     t)
  65                   (all-uppercase nil))
  66               (acond
  67                 ((nth-value 1
  68                    (cl-ppcre:scan-to-strings
  69                     "[\\*|\\+](.+)[\\*|\\+](.*)"
  70                     identifier :sharedp t))
  71                  (setf all-uppercase t
  72                        identifier (concatenate
  73                                    'string (aref it 0) (aref it 1))))
  74                 ((and (> (length identifier) 1)
  75                       (or (eql (char identifier 0) #\+)
  76                           (eql (char identifier 0) #\*)))
  77                  (setf lowercase  nil
  78                        identifier (subseq identifier 1))))
  79               (with-output-to-string (acc)
  80                 (loop
  81                    for c across identifier
  82                    do (acond
  83                        ((eql c #\-)
  84                         (setf lowercase (not lowercase)))
  85                        ((position c "!?#@%+*/=:<>^")
  86                         (write-sequence
  87                          (aref #("bang" "what" "hash" "at" "percent"
  88                                  "plus" "star" "slash" "equals" "colon"
  89                                  "lessthan" "greaterthan" "caret")
  90                                it)
  91                          acc))
  92                        (t
  93                         (write-char
  94                          (if (and lowercase (not all-uppercase))
  95                              (char-downcase c)
  96                              (char-upcase c))
  97                          acc)
  98                         (setf lowercase t)))))))
  99           (#.(eql :invert (readtable-case
 100                            (named-readtables:find-readtable :parenscript)))
 101              (cond
 102                ((every #'upper-case-p
 103                        (remove-if-not #'alpha-char-p identifier))
 104                 (string-downcase identifier))
 105                ((every #'lower-case-p
 106                        (remove-if-not #'alpha-char-p identifier))
 107                 (string-upcase identifier))
 108                (t identifier)))
 109           (t identifier))))))
 110
 111 (defun ordered-set-difference (list1 list2 &key (test #'eql))
 112   "CL set-difference may not preserve order."
 113   (reduce (lambda (list el) (remove el list :test test))
 114           (cons list1 list2)))
 115
 116 (defun flatten (x &optional acc)
 117   (cond ((null x) acc)
 118         ((atom x) (cons x acc))
 119         (t (flatten (car x) (flatten (cdr x) acc)))))
 120
 121 (defun tree-search (A tree)
 122   (or (equal A tree)
 123       (when (consp tree)
 124         (loop for x on tree thereis ;; fucking dotted lists
 125               (or (tree-search A (car x))
 126                   (unless (listp (cdr x))
 127                     (equal A (cdr x))))))))
 128
 129 (labels ((compare (a b op equality)
 130            (if (not (stringp a)) (setf a (format nil "~A" a)))
 131            (if (not (stringp b)) (setf b (format nil "~A" b)))
 132            (loop with i := 0 and j := 0 and m and n
 133                  while (or i j)
 134                  do (multiple-value-setq (m i)
 135                       (if (and i (< i (length a)))
 136                           (parse-integer a :start i :junk-allowed t)))
 137                     (multiple-value-setq (n j)
 138                       (if (and j (< j (length b)))
 139                           (parse-integer b :start j :junk-allowed t)))
 140                  if (not m) do (setf m -1) else do (incf i)
 141                  if (not n) do (setf n -1) else do (incf j)
 142                  do (let ((op-p (funcall op m n))
 143                           (rev-op-p (funcall op n m)))
 144                       (cond
 145                         ((and op-p (not (and rev-op-p equality)))
 146                          (return t))
 147                         ((and rev-op-p (not (and op-p equality)))
 148                          (return nil))
 149                         ((and (not (or op-p rev-op-p)) equality)
 150                          (return nil))))
 151                  finally (return equality))))
 152   (defun vstring< (a b) (compare a b #'< nil))
 153   (defun vstring<= (a b) (compare a b #'<= t))
 154   (defun vstring= (a b) (compare a b #'= t))
 155   (defun vstring>= (a b) (compare a b #'>= t))
 156   (defun vstring> (a b) (compare a b #'> nil)))