1 (in-package "PARENSCRIPT")
3 (defun string-join (strings separator)
4 (format nil "~{~}" (format nil "~~a~~^~a" separator) strings))
6 (defun val-to-string (val)
8 (string-downcase (symbol-name val))
9 (princ-to-string val)))
11 (defun string-split (string separators &key (keep-separators nil) (remove-empty-subseqs nil))
12 (do ((len (length string))
17 (let ((split (if (> i last)
18 (cons (subseq string last i) res)
20 (nreverse (if remove-empty-subseqs
21 (delete "" split :test #'string-equal)
23 (when (member (char string i) separators)
24 (push (subseq string last i) res)
25 (when keep-separators (push (string (char string i)) res))
28 (defparameter *special-chars*
39 ;;; Parenscript-style symbol -> Javascript-style symbol
41 (defun constant-string-p (string)
42 (let ((len (length string))
43 (constant-chars '(#\+ #\*)))
45 (member (char string 0) constant-chars)
46 (member (char string (1- len)) constant-chars))))
48 (defun first-uppercase-p (string)
49 (and (> (length string) 1)
50 (member (char string 0) '(#\+ #\*))))
52 (defun untouchable-string-p (string)
53 (and (> (length string) 1)
54 (char= #\: (char string 0))))
56 (defun symbol-to-js-string (symbol)
57 "Given a Lisp symbol or string, produces to a valid JavaScript
58 identifier by following transformation heuristics case conversion. For
59 example, paren-script becomes parenScript, *some-global* becomes
61 (when (symbolp symbol)
62 (setf symbol (symbol-name symbol)))
63 (let ((symbols (string-split symbol '(#\. #\[ #\]) :keep-separators t :remove-empty-subseqs t)))
64 (cond ((null symbols) "")
65 ((= (length symbols) 1)
70 (cond ((constant-string-p symbol)
72 symbol (subseq symbol 1 (1- (length symbol)))))
73 ((first-uppercase-p symbol)
75 symbol (subseq symbol 1)))
76 ((untouchable-string-p symbol)
78 symbol (subseq symbol 1))))
82 ((and lowercase (not all-uppercase))
87 (dotimes (i (length symbol))
88 (let ((c (char symbol i)))
91 (setf lowercase (not lowercase)))
92 ((assoc c *special-chars*)
93 (dolist (i (coerce (cdr (assoc c *special-chars*)) 'list))
96 (coerce (nreverse res) 'string)))
97 (t (string-join (mapcar #'symbol-to-js-string symbols) "")))))
99 (defun ordered-set-difference (list1 list2 &key (test #'eql)) ; because the CL set-difference may not preserve order
100 (reduce (lambda (list el) (remove el list :test test))
103 (defun flatten (x &optional acc)
105 ((atom x) (cons x acc))
106 (t (flatten (car x) (flatten (cdr x) acc)))))
108 (defmacro aif (test-form then-form &optional else-form)
109 `(let ((it ,test-form))
110 (if it ,then-form ,else-form)))
112 (defmacro once-only ((&rest names) &body body) ;; the version from PCL
113 (let ((gensyms (loop for nil in names collect (gensym))))
114 `(let (,@(loop for g in gensyms collect `(,g (gensym))))
115 `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
116 ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))