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 flatten-blocks (body)
 122   (when body
 123     (if (and (listp (car body)) (eq 'ps-js:block (caar body)))
 124         (append (flatten-blocks (cdr (car body)))
 125                 (flatten-blocks (cdr body)))
 126         (cons (car body) (flatten-blocks (cdr body))))))
 127
 128 (defun tree-find (A tree)
 129   (or (equal A tree)
 130       (when (consp tree)
 131         (loop for x on tree thereis
 132               (or (tree-find A (car x))
 133                   (unless (listp (cdr x))
 134                     (equal A (cdr x))))))))
 135
 136 (defun parse-semver (semver-string)
 137   (let ((semver-list   (cl-ppcre:split "\\." semver-string))
 138         (semver-scaled 0))
 139     (dotimes (i 3)
 140       (incf semver-scaled
 141             (* (expt 1000 (- 2 i))
 142                (parse-integer (or (nth i semver-list) "0")))))
 143     semver-scaled))
 144
 145 (defun js-target-at-least (version)
 146   (>= (parse-semver *js-target-version*) (parse-semver version)))