'((#\! . "Bang")
(#\? . "What")
(#\# . "Hash")
- (#\$ . "Dollar")
(#\@ . "At")
(#\% . "Percent")
(#\+ . "Plus")
(flet ((special-append (form elt)
(let ((len (length form)))
(if (and (> len 0)
- (member (char form (1- len))
- '(#\; #\, #\})))
+ (string= (char form (1- len)) elt))
form
(concatenate 'string form elt)))))
(cond ((stringp form)
(defvar *js-compiler-macros* (make-hash-table :test 'equal)
"*JS-COMPILER-MACROS* is a hash-table containing the functions corresponding
to javascript special forms, indexed by their name. Javascript special
-forms are compiler macros for JS expressions."))
+forms are compiler macros for JS expressions.")
+
+ (defun undefine-js-compiler-macro (name)
+ (declare (type symbol name))
+ (when (gethash (symbol-name name) *js-compiler-macros*)
+ (warn "Redefining compiler macro ~S" name)
+ (remhash (symbol-name name) *js-compiler-macros*))))
(defmacro define-js-compiler-macro (name lambda-list &rest body)
"Define a javascript compiler macro NAME. Arguments are destructured
(defmacro defjsmacro (name args &rest body)
"Define a javascript macro, and store it in the toplevel macro environment."
- (when (gethash (symbol-name name) *js-compiler-macros*)
- (warn "Redefining compiler macro ~S" name)
- (remhash (symbol-name name) *js-compiler-macros*))
(let ((lambda-list (gensym)))
+ (undefine-js-compiler-macro name)
`(setf (gethash ,(symbol-name name) *js-macro-toplevel*)
#'(lambda (&rest ,lambda-list)
- (destructuring-bind ,args ,lambda-list ,@body)))))
+ (destructuring-bind ,args ,lambda-list ,@body)))))
+
+(defun import-macros-from-lisp (&rest names)
+ "Import the named lisp macros into the js macro expansion"
+ (dolist (name names)
+ (let ((name name))
+ (undefine-js-compiler-macro name)
+ (setf (gethash (symbol-name name) *js-macro-toplevel*)
+ (lambda (&rest args)
+ (macroexpand `(,name ,@args)))))))
(defun js-expand-form (expr)
"Expand a javascript form."
(js-expand-form (apply js-macro (cdr expr)))
expr)))))
+(defvar *gen-js-name-counter* 0)
+
+(defun gen-js-name-string (&key (prefix "_ps_"))
+ "Generates a unique valid javascript identifier ()"
+ (concatenate 'string
+ prefix (princ-to-string (incf *gen-js-name-counter*))))
+
+(defun gen-js-name (&key (prefix "_ps_"))
+ "Generate a new javascript identifier."
+ (intern (gen-js-name-string :prefix prefix)
+ (find-package :js)))
+
+(defmacro with-unique-js-names (symbols &body body)
+ "Evaluate BODY with the variables on SYMBOLS bound to new javascript identifiers.
+
+Each element of SYMBOLS is either a symbol or a list of (symbol
+prefix)."
+ `(let* ,(mapcar (lambda (symbol)
+ (destructuring-bind (symbol &optional prefix)
+ (if (consp symbol)
+ symbol
+ (list symbol))
+ (if prefix
+ `(,symbol (gen-js-name :prefix ,prefix))
+ `(,symbol (gen-js-name)))))
+ symbols)
+ ,@body))
+
+(defjsmacro rebind (variables expression)
+ ;; Creates a new js lexical environment and copies the given
+ ;; variable(s) there. Executes the body in the new environment. This
+ ;; has the same effect as a new (let () ...) form in lisp but works on
+ ;; the js side for js closures."
+
+ (unless (listp variables)
+ (setf variables (list variables)))
+ `((lambda ()
+ (let ((new-context (new *object)))
+ ,@(loop for variable in variables
+ do (setf variable (symbol-to-js variable))
+ collect `(setf (slot-value new-context ,variable) (slot-value this ,variable)))
+ (with new-context
+ (return ,expression))))))
+
(defvar *var-counter* 0)
(defun js-gensym (&optional (name "js"))
(defjsclass string-literal (expression)
(value))
+(defvar *js-quote-char* #\'
+ "Specifies which character JS sholud use for delimiting strings.
+
+This variable is usefull when have to embed some javascript code
+in an html attribute delimited by #\\\" as opposed to #\\', or
+vice-versa.")
+
(defmethod js-to-strings ((string string-literal) start-pos)
- (declare (ignore start-pos))
+ (declare (ignore start-pos)
+ (inline lisp-special-char-to-js))
(list (with-output-to-string (escaped)
+ (write-char *js-quote-char* escaped)
(loop
- initially (write-char #\' escaped)
- for char across (value string)
- if (char= #\' char)
- do (write-string "\\'" escaped)
- else
- do (write-char char escaped)
- finally (write-char #\' escaped)))))
+ for char across (value string)
+ for code = (char-code char)
+ for special = (lisp-special-char-to-js char)
+ do
+ (cond
+ (special
+ (write-char #\\ escaped)
+ (write-char special escaped))
+ ((or (<= code #x1f) (>= code #x80))
+ (format escaped "\\u~4,'0x" code))
+ (t (write-char char escaped)))
+ finally (write-char *js-quote-char* escaped)))))
+
+(defparameter *js-lisp-escaped-chars*
+ '((#\' . #\')
+ (#\\ . #\\)
+ (#\b . #\Backspace)
+ (#\f . #.(code-char 12))
+ (#\n . #\Newline)
+ (#\r . #\Return)
+ (#\t . #\Tab)))
+
+(defun lisp-special-char-to-js(lisp-char)
+ (car (rassoc lisp-char *js-lisp-escaped-chars*)))
;;; number literals
(define-js-single-op delete)
(define-js-single-op void)
(define-js-single-op typeof)
-(define-js-single-op instanceof)
(define-js-single-op new)
+;; TODO this may not be the best integrated implementation of
+;; instanceof into the rest of the code
+(defjsclass js-instanceof (expression)
+ ((value)
+ (type :initarg :type)))
+
+(define-js-compiler-macro instanceof (value type)
+ (make-instance 'js-instanceof
+ :value (js-compile-to-expression value)
+ :type (js-compile-to-expression type)))
+
+(defmethod js-to-strings ((instanceof js-instanceof) start-pos)
+ (dwim-join
+ (list (js-to-strings (value instanceof) (+ start-pos 2))
+ (list "instanceof")
+ (js-to-strings (slot-value instanceof 'type) (+ start-pos 2)))
+ (- 80 start-pos 2)
+ :white-space
+ " "))
+
;;; assignment
(defjsclass js-setf (expression)
(define-js-compiler-macro with (statement &rest body)
(make-instance 'js-with
- :obj (js-compile-to-expression (first statement))
- :body (js-compile-to-body (cons 'progn body) :indent " ")))
+ :obj (js-compile-to-expression statement)
+ :body (js-compile-to-body (cons 'progn body) :indent " ")))
(defmethod js-to-statement-strings ((with js-with) start-pos)
(nconc (dwim-join (list (js-to-strings (with-obj with) (+ start-pos 2)))
(define-js-compiler-macro regex (regex)
(make-instance 'regex :value (string regex)))
+(defun first-slash-p (string)
+ (and (> (length string) 0)
+ (eq (char string 0) '#\/)))
+
+(defmethod js-to-strings ((regex regex) start-pos)
+ (declare (ignore start-pos))
+ (let ((slash (if (first-slash-p (value regex)) nil "/")))
+ (list (format nil (concatenate 'string slash "~A" slash) (value regex)))))
+
;;; conditional compilation
(defjsclass cc-if ()
(setf form (js-expand-form form))
(cond ((stringp form)
(make-instance 'string-literal :value form))
+ ((characterp form)
+ (make-instance 'string-literal :value (string form)))
((numberp form)
(make-instance 'number-literal :value form))
((symbolp form)
(defjsmacro random ()
`(*Math.random))
-;;; helper functions
-
-(defvar *gen-js-name-counter* 0)
-
-(defun gen-js-name-string (&key (prefix "parenscript_"))
- "Generates a unique valid javascript identifier ()"
- (concatenate 'string
- prefix (princ-to-string (incf *gen-js-name-counter*))))
-
-(defun gen-js-name (&key (prefix "parenscript_"))
- "Generate a new javascript identifier."
- (intern (gen-js-name-string :prefix prefix)
- (find-package :js)))
-
-(defmacro with-unique-js-names (symbols &body body)
- "Evaluate BODY with the variables on SYMBOLS bound to new javascript identifiers.
-
-Each element of SYMBOLS is either a symbol or a list of (symbol
-prefix)."
- `(let* ,(mapcar (lambda (symbol)
- (destructuring-bind (symbol &optional prefix)
- (if (consp symbol)
- symbol
- (list symbol))
- (if prefix
- `(,symbol (gen-js-name :prefix ,prefix))
- `(,symbol (gen-js-name)))))
- symbols)
- ,@body))
-
;;; helper macros
(define-js-compiler-macro js (&rest body)
HCoop / clinton / parenscript.git / blobdiff