src/utils.lisp

   1 (in-package #:parenscript)
   2
   3 (let ((cache (make-hash-table :test 'equal)))
   4   (defun encode-js-identifier (identifier)
   5     "Given a string, produces to a valid JavaScript identifier by
   6 following transformation heuristics case conversion. For example,
   7 paren-script becomes parenScript, *some-global* becomes SOMEGLOBAL."
   8     (or (gethash identifier cache)
   9         (setf (gethash identifier cache)
  10               (cond ((some (lambda (c) (find c "-*+!?#@%/=:<>^")) identifier)
  11                      (let ((lowercase t)
  12                            (all-uppercase nil))
  13                        (when (and (not (string= identifier "[]")) ;; HACK
  14                                   (find-if (lambda (x) (find x '(#\. #\[ #\]))) identifier))
  15                          (warn "Symbol ~A contains one of '.[]' - this compound naming convention is no longer supported by Parenscript!"
  16                                identifier))
  17                        (acond ((nth-value 1 (cl-ppcre:scan-to-strings "[\\*|\\+](.+)[\\*|\\+](.*)" identifier :sharedp t))
  18                                (setf all-uppercase t
  19                                      identifier (concatenate 'string (aref it 0) (aref it 1))))
  20                               ((and (> (length identifier) 1)
  21                                     (or (eql (char identifier 0) #\+)
  22                                         (eql (char identifier 0) #\*)))
  23                                (setf lowercase nil
  24                                      identifier (subseq identifier 1))))
  25                        (with-output-to-string (acc)
  26                          (loop for c across identifier
  27                             do (acond ((eql c #\-)
  28                                        (setf lowercase (not lowercase)))
  29                                       ((position c "!?#@%+*/=:<>^")
  30                                        (write-sequence (aref #("bang" "what" "hash" "at" "percent"
  31                                                                "plus" "star" "slash" "equals" "colon"
  32                                                                "lessthan" "greaterthan" "caret")
  33                                                              it)
  34                                                        acc))
  35                                       (t (write-char (cond ((and lowercase (not all-uppercase)) (char-downcase c))
  36                                                            (t (char-upcase c)))
  37                                                      acc)
  38                                          (setf lowercase t)))))))
  39                     ((every #'upper-case-p (remove-if-not #'alpha-char-p identifier)) (string-downcase identifier))
  40                     ((every #'lower-case-p (remove-if-not #'alpha-char-p identifier)) (string-upcase identifier))
  41                     (t identifier))))))
  42
  43 (defun ordered-set-difference (list1 list2 &key (test #'eql)) ; because the CL set-difference may not preserve order
  44   (reduce (lambda (list el) (remove el list :test test))
  45           (cons list1 list2)))
  46
  47 (defmacro once-only ((&rest names) &body body) ;; the version from PCL
  48   (let ((gensyms (loop for nil in names collect (gensym))))
  49     `(let (,@(loop for g in gensyms collect `(,g (gensym))))
  50        `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
  51           ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
  52                 ,@body)))))
  53
  54 (defun flatten (x &optional acc)
  55   (cond ((null x) acc)
  56         ((atom x) (cons x acc))
  57         (t (flatten (car x) (flatten (cdr x) acc)))))