1 (in-package "PARENSCRIPT")
3 (defun string-join (strings separator
)
4 (format nil
"~{~}" (format nil
"~~a~~^~a" separator
) strings
))
6 (defun string-split (string separators
&key
(keep-separators nil
) (remove-empty-subseqs nil
))
7 (do ((len (length string
))
12 (let ((split (if (> i last
)
13 (cons (subseq string last i
) res
)
15 (nreverse (if remove-empty-subseqs
16 (delete "" split
:test
#'string-equal
)
18 (when (member (char string i
) separators
)
19 (push (subseq string last i
) res
)
20 (when keep-separators
(push (string (char string i
)) res
))
23 (defparameter *special-chars
*
35 ;;; Parenscript-style symbol -> Javascript-style symbol
37 (defun special-symbol-delimiter?
(char)
38 (or (eql char
#\
+) (eql char
#\
*)))
40 (defun special-symbol-name?
(string)
41 (nth-value 1 (cl-ppcre:scan-to-strings
"[\\*|\\+](.*)[\\*|\\+](.*)" string
)))
43 (defun first-uppercase-p (string)
44 (and (> (length string
) 1)
45 (special-symbol-delimiter?
(char string
0))))
47 (defun untouchable-string-p (string)
48 (and (> (length string
) 1)
49 (char= #\
: (char string
0))))
51 (defun symbol-name-to-js-string (symbol)
52 "Given a Lisp symbol or string, produces to a valid JavaScript
53 identifier by following transformation heuristics case conversion. For
54 example, paren-script becomes parenScript, *some-global* becomes
56 (let ((sym-name (string symbol
))
61 (when (and (not (eq symbol
'[]))
62 (find-if (lambda (x) (member x
'(#\.
#\
[ #\
]))) sym-name
))
63 (warn "Symbol ~A contains one of '.[]' - this compound naming convention is no longer supported by Parenscript!"
65 (cond ((special-symbol-name? sym-name
)
67 sym-name
(let ((parts (special-symbol-name? sym-name
)))
68 (concatenate 'string
(aref parts
0) (aref parts
1)))))
69 ((first-uppercase-p sym-name
)
71 sym-name
(subseq sym-name
1)))
72 ((untouchable-string-p sym-name
)
74 sym-name
(subseq sym-name
1))))
76 (push (cond (do-not-touch c
)
77 ((and lowercase
(not all-uppercase
)) (char-downcase c
))
81 (dotimes (i (length sym-name
))
82 (let ((c (char sym-name i
)))
84 (setf lowercase
(not lowercase
)))
85 ((assoc c
*special-chars
*)
86 (dolist (i (coerce (cdr (assoc c
*special-chars
*)) 'list
))
89 (coerce (nreverse res
) 'string
)))
91 (defun ordered-set-difference (list1 list2
&key
(test #'eql
)) ; because the CL set-difference may not preserve order
92 (reduce (lambda (list el
) (remove el list
:test test
))
95 (defmacro once-only
((&rest names
) &body body
) ;; the version from PCL
96 (let ((gensyms (loop for nil in names collect
(gensym))))
97 `(let (,@(loop for g in gensyms collect
`(,g
(gensym))))
98 `(let (,,@(loop for g in gensyms for n in names collect
``(,,g
,,n
)))
99 ,(let (,@(loop for n in names for g in gensyms collect
`(,n
,g
)))
105 (mapcan #'flatten x
)))