1 (in-package #:parenscript
)
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
)
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!"
17 (acond ((nth-value 1 (cl-ppcre:scan-to-strings
"[\\*|\\+](.+)[\\*|\\+](.*)" identifier
:sharedp 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) #\
*)))
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")
35 (t (write-char (cond ((and lowercase
(not all-uppercase
)) (char-downcase c
))
38 (setf lowercase t
)))))))
39 ((some #'lower-case-p identifier
) identifier
)
40 (t (string-downcase identifier
)))))))
42 (defun ordered-set-difference (list1 list2
&key
(test #'eql
)) ; because the CL set-difference may not preserve order
43 (reduce (lambda (list el
) (remove el list
:test test
))
46 (defmacro once-only
((&rest names
) &body body
) ;; the version from PCL
47 (let ((gensyms (loop for nil in names collect
(gensym))))
48 `(let (,@(loop for g in gensyms collect
`(,g
(gensym))))
49 `(let (,,@(loop for g in gensyms for n in names collect
``(,,g
,,n
)))
50 ,(let (,@(loop for n in names for g in gensyms collect
`(,n
,g
)))
53 (defun flatten (x &optional acc
)
55 ((atom x
) (cons x acc
))
56 (t (flatten (car x
) (flatten (cdr x
) acc
)))))