Removed some unnecessary code that ignored an anaphor in define-ps-special-form ...

[clinton/parenscript.git] / src / utils.lisp

diff --git a/src/utils.lisp b/src/utils.lisp
index 51cbaf8..4ce2ab4 100644 (file)
--- a/src/utils.lisp
+++ b/src/utils.lisp
@@ -1,4 +1,4 @@
-(in-package :parenscript)
+(in-package "PARENSCRIPT")
 
 (defun string-join (strings separator)
   (format nil "~{~}" (format nil "~~a~~^~a" separator) strings))
@@ -15,8 +15,8 @@
        res)
       ((= i len)
        (let ((split (if (> i last)
-                    (cons (subseq string last i) res)
-                    res)))
+                     (cons (subseq string last i) res)
+                     res)))
          (nreverse (if remove-empty-subseqs
                        (delete "" split :test #'string-equal)
                        split))))
@@ -25,13 +25,6 @@
       (when keep-separators (push (string (char string i)) res))
       (setf last (1+ i)))))
 
-(defun concat-constant-strings (list)
-  (reverse (reduce (lambda (optimized-list next-obj)
-                     (if (and (or (numberp next-obj) (stringp next-obj)) (stringp (car optimized-list)))
-                         (cons (format nil "~a~a" (car optimized-list) next-obj) (cdr optimized-list))
-                         (cons next-obj optimized-list)))
-                   (cons () list))))
-
 (defparameter *special-chars*
   '((#\! . "Bang")
     (#\? . "What")
@@ -40,7 +33,8 @@
     (#\% . "Percent")
     (#\+ . "Plus")
     (#\* . "Star")
-    (#\/ . "Slash")))
+    (#\/ . "Slash")
+    (#\= . "Equals")))
 
 ;;; Parenscript-style symbol -> Javascript-style symbol
 
@@ -59,7 +53,7 @@
   (and (> (length string) 1)
        (char= #\: (char string 0))))
 
-(defun symbol-to-js (symbol)
+(defun symbol-to-js-string (symbol)
   "Given a Lisp symbol or string, produces to a valid JavaScript
 identifier by following transformation heuristics case conversion. For
 example, paren-script becomes parenScript, *some-global* becomes
@@ -68,40 +62,51 @@ SOMEGLOBAL."
     (setf symbol (symbol-name symbol)))
   (let ((symbols (string-split symbol '(#\. #\[ #\]) :keep-separators t :remove-empty-subseqs t)))
     (cond ((null symbols) "")
-         ((= (length symbols) 1)
-          (let (res
+          ((= (length symbols) 1)
+           (let (res
                  (do-not-touch nil)
-                (lowercase t)
-                (all-uppercase nil))
-            (cond ((constant-string-p symbol)
-                   (setf all-uppercase t
-                         symbol (subseq symbol 1 (1- (length symbol)))))
-                  ((first-uppercase-p symbol)
-                   (setf lowercase nil
-                         symbol (subseq symbol 1)))
+                 (lowercase t)
+                 (all-uppercase nil))
+             (cond ((constant-string-p symbol)
+                    (setf all-uppercase t
+                          symbol (subseq symbol 1 (1- (length symbol)))))
+                   ((first-uppercase-p symbol)
+                    (setf lowercase nil
+                          symbol (subseq symbol 1)))
                    ((untouchable-string-p symbol)
                     (setf do-not-touch t
                           symbol (subseq symbol 1))))
-            (flet ((reschar (c)
-                     (push (cond
+             (flet ((reschar (c)
+                      (push (cond
                               (do-not-touch c)
                               ((and lowercase (not all-uppercase))
                                (char-downcase c))
                               (t (char-upcase c)))
                             res)
-                     (setf lowercase t)))
-              (dotimes (i (length symbol))
-                (let ((c (char symbol i)))
-                  (cond
-                    ((eql c #\-)
-                     (setf lowercase (not lowercase)))
-                    ((assoc c *special-chars*)
-                     (dolist (i (coerce (cdr (assoc c *special-chars*)) 'list))
-                       (reschar i)))
-                    (t (reschar c))))))
-            (coerce (nreverse res) 'string)))
-         (t (string-join (mapcar #'symbol-to-js symbols) "")))))
+                      (setf lowercase t)))
+               (dotimes (i (length symbol))
+                 (let ((c (char symbol i)))
+                   (cond
+                     ((eql c #\-)
+                      (setf lowercase (not lowercase)))
+                     ((assoc c *special-chars*)
+                      (dolist (i (coerce (cdr (assoc c *special-chars*)) 'list))
+                        (reschar i)))
+                     (t (reschar c))))))
+             (coerce (nreverse res) 'string)))
+          (t (string-join (mapcar #'symbol-to-js-string symbols) "")))))
 
-(defun ordered-set-difference (list1 list2 &key (test #'eql)) ;; because the CL set-difference may not preserve order
+(defun ordered-set-difference (list1 list2 &key (test #'eql)) ; because the CL set-difference may not preserve order
   (reduce (lambda (list el) (remove el list :test test))
-          (cons list1 list2)))
\ No newline at end of file
+          (cons list1 list2)))
+
+(defmacro aif (test-form then-form &optional else-form)
+  `(let ((it ,test-form))
+     (if it ,then-form ,else-form)))
+
+(defmacro once-only ((&rest names) &body body) ;; the version from PCL
+  (let ((gensyms (loop for nil in names collect (gensym))))
+    `(let (,@(loop for g in gensyms collect `(,g (gensym))))
+       `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
+          ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
+                ,@body)))))