src/utils.lisp

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