(:module :src
:components ((:file "package")
(:file "utils" :depends-on ("package"))
- (:file "js-source-model" :depends-on ("package" "utils"))
- (:file "ps-source-model" :depends-on ("js-source-model"))
- (:file "namespace" :depends-on ("js-source-model" "ps-source-model"))
- (:file "parser" :depends-on ("js-source-model" "ps-source-model" "namespace"))
- (:file "builtin-packages" :depends-on ("parser"))
- (:file "deprecated-interface" :depends-on ("parser"))
- (:file "parse-lambda-list" :depends-on ("package"))
- (:file "js-macrology" :depends-on ("deprecated-interface"))
+ (:file "namespace" :depends-on ("package"))
+ (:file "parse-lambda-list" :depends-on ("package"))
+ (:file "parser" :depends-on ("namespace"))
+ (:file "js-macrology" :depends-on ("parser"))
(:file "ps-macrology" :depends-on ("js-macrology" "parse-lambda-list"))
(:file "js-translation" :depends-on ("ps-macrology"))
; (:file "js-ugly-translation" :depends-on ("js-translation"))
- (:file "compilation-interface" :depends-on ("package" "js-translation" "builtin-packages")); "js-ugly-translation"))
+ (:file "compilation-interface" :depends-on ("package" "js-translation")); "js-ugly-translation"))
+ (:file "deprecated-interface" :depends-on ("compilation-interface"))
;; standard library
(:module :lib
:components ((:static-file "functional.lisp")
+++ /dev/null
-(in-package :parenscript)
-
-(defmethod setup-compilation-environment ((comp-env compilation-environment))
- (install-standard-script-packages comp-env)
- (setf (comp-env-current-package comp-env)
- (find-script-package :parenscript-user comp-env))
- comp-env)
-
-(defparameter *javascript-exports*
- (append
- nil
- cl-user::*shared-symbols-ps-js*))
-
-(defparameter *parenscript-exports*
- (append
- *javascript-exports*
- cl-user::*parenscript-lang-exports*
- nil
- ))
-
-(defgeneric install-standard-script-packages (comp-env)
- (:documentation "Creates standard script packages and installs them in the current compilation
-environment."))
-
-(defmethod install-standard-script-packages ((comp-env compilation-environment))
- (list
- (create-script-package
- comp-env
- :name "KEYWORD" :lisp-package :keyword)
- (create-script-package
- comp-env
- :name "GLOBAL" :lisp-package :parenscript.global)
- ;; symbols in the parenscript, javascript and parenscript-user packages are non-prefixed
- (create-script-package
- comp-env
- :name "JAVASCRIPT" :prefix "" :nicknames (list "JS") :lisp-package :parenscript.javascript
- :exports *javascript-exports*
- :secondary-lisp-packages '(:common-lisp))
- (create-script-package
- comp-env
- :name "PARENSCRIPT" :prefix "" :lisp-package :parenscript
- :exports *parenscript-exports*
- :used-packages '(:javascript)
- )
- (create-script-package
- comp-env
- :name "PARENSCRIPT-USER" :prefix "" :lisp-package :parenscript-user
- :secondary-lisp-packages (list :cl-user)
- :used-packages '("PARENSCRIPT")
- :nicknames '("PS-USER" "PAREN-USER"))
- (create-script-package
- comp-env
- :name "PS_GS" :lisp-package :parenscript.ps-gensyms)
- (create-script-package
- comp-env
- :name "UNINTERNED" :prefix "")))
\ No newline at end of file
-(in-package :parenscript)
-
-(defmacro with-new-compilation-environment ((var) &body body)
- `(let* ((,var (make-basic-compilation-environment))
- (*compilation-environment* ,var))
- ,@body))
-
-(defun translate-ast (compiled-expr
- &key
- (comp-env *compilation-environment*)
- (output-stream *standard-output*)
- (output-spec :javascript)
- (pretty-print t))
- "Translates a compiled Parenscript program (compiled with COMPILE-PAREN-FORM)
-to a Javascript string. Outputs to the stream OUTPUT-STREAM in the language given
-by OUTPUT-SPEC, pretty printing if PRETTY-PRINT is non-null.
-
-OUTPUT-SPEC must be :javascript at the moment."
- (declare (ignore comp-env))
- (when (not (eql :javascript output-spec))
- (error "Unsupported output-spec for translation: ~A" output-spec))
- (when (eql :javascript output-spec)
-; (if (not pretty-print)
-; (js-translate compiled-expr :statement output-stream)
- (write-string (string-join
- (ps-js::js-to-statement-strings compiled-expr 0)
- (string #\Newline))
- output-stream)))
-
-(defun non-nil-comp-env ()
- "Returns a sane compilation environment. Either the one currently bound or a new
-one."
- (or *compilation-environment*
- (make-basic-compilation-environment)))
-
-
-(defun compile-script (script-form
- &key
- (output-spec :javascript)
- (pretty-print t)
- (output-stream nil)
- (toplevel-p t)
- (comp-env (non-nil-comp-env)))
- "Compiles the Parenscript form SCRIPT-FORM into the language specified by OUTPUT-SPEC.
-Non-null PRETTY-PRINT values result in a pretty-printed output code. If OUTPUT-STREAM
-is NIL, then the result is a string; otherwise code is output to the OUTPUT-STREAM stream.
-COMP-ENV is the compilation environment in which to compile the form.
-
-This is the main function used by Parenscript users to compile their code to Javascript (and
-potentially other languages)."
- (macrolet ((with-output-stream ((var) &body body)
- `(if (null output-stream)
- (with-output-to-string (,var)
- ,@body)
- (let ((,var output-stream))
- ,@body))))
- ;; we might want to bind this rather than set it
- (setf (comp-env-compiling-toplevel-p comp-env) toplevel-p)
- (with-output-stream (stream)
- (let* ((*compilation-environment* comp-env)
- (compiled (let ((first-result (compile-parenscript-form comp-env script-form)))
- (if (not toplevel-p)
- first-result
- (progn
- (setf (comp-env-compiling-toplevel-p comp-env) nil)
- (compile-parenscript-form comp-env first-result))))))
- (translate-ast
- compiled
-; (compile-script-form script-form :comp-env comp-env)
- :comp-env comp-env
- :output-stream stream
- :output-spec output-spec
- :pretty-print pretty-print)))))
-
-(defun ps-to-string (expr)
- "Given an AST node, compiles it to a Javascript string."
- (string-join
- (ps-js::js-to-statement-strings (compile-script-form expr) 0)
- (string #\Newline)))
-
-;;; SEXPs -> Javascript string functionality
-(defmacro script (&body body)
- "A macro that returns a Javascript string of the supplied Parenscript forms."
- `(script* '(progn ,@body)))
-
-(defun script* (&rest body)
- "Return the javascript string representing BODY.
-Body is evaluated."
- (compile-script `(progn ,@body)))
-
-;;; Handy synonyms
-(defmacro ps (&body body)
- `(script ,@body))
-
-(defmacro ps* (&body body)
- `(script* ,@body))
-
-(defmacro js (&body body)
- `(script ,@body))
-
-(defmacro js* (&body body)
- `(script* ,@body))
+(in-package :parenscript)
+
+(defun translate-ast (compiled-expr &key (output-stream *standard-output*) (output-spec :javascript) (pretty-print t))
+ "Translates a compiled Parenscript program (compiled with COMPILE-PAREN-FORM)
+to a Javascript string. Outputs to the stream OUTPUT-STREAM in the language given
+by OUTPUT-SPEC, pretty printing if PRETTY-PRINT is non-null.
+
+OUTPUT-SPEC must be :javascript at the moment."
+ (when (not (eql :javascript output-spec))
+ (error "Unsupported output-spec for translation: ~A" output-spec))
+ (write-string (string-join (ps-print compiled-expr 0)
+ (string #\Newline))
+ output-stream))
+
+(defun compile-script (script-form &key (output-spec :javascript) (pretty-print t) (output-stream nil) (toplevel-p t))
+ "Compiles the Parenscript form SCRIPT-FORM into the language specified by OUTPUT-SPEC.
+Non-null PRETTY-PRINT values result in a pretty-printed output code. If OUTPUT-STREAM
+is NIL, then the result is a string; otherwise code is output to the OUTPUT-STREAM stream.
+
+This is the main function used by Parenscript users to compile their code to Javascript (and
+potentially other languages)."
+ (macrolet ((with-output-stream ((var) &body body)
+ `(if (null output-stream)
+ (with-output-to-string (,var)
+ ,@body)
+ (let ((,var output-stream))
+ ,@body))))
+ (with-output-stream (stream)
+ (translate-ast (compile-parenscript-form script-form)
+ :output-stream stream
+ :output-spec output-spec
+ :pretty-print pretty-print))))
+
+(defun ps-to-string (expr)
+ (string-join (ps-print (compile-parenscript-form expr) 0) (string #\Newline)))
+
+(defmacro ps (&body body)
+ "A macro that returns a Javascript string of the supplied Parenscript forms."
+ `(ps* '(progn ,@body)))
+
+(defun ps* (&rest body)
+ "Return the javascript string representing BODY.
+Body is evaluated."
+ (compile-script `(progn ,@body)))
(defmacro defjsmacro (&rest args)
(warn-deprecated 'defjsmacro 'defpsmacro)
- `(defscriptmacro ,@args))
+ `(defpsmacro ,@args))
(defmacro js-file (&rest body)
(warn-deprecated 'js-file)
(defmacro gen-js-name (&rest args)
(warn-deprecated 'gen-js-name 'gen-ps-name)
- `(gen-ps-name ,@args))
+ `(ps-gensym ,@args))
-(defmacro gen-js-name-string (&rest args)
- (warn-deprecated 'gen-js-name-string 'gen-script-name-string)
- `(gen-script-name-string ,@args))
+(defmacro js (&rest args)
+ `(ps ,@args))
+
+(defmacro js* (&rest args)
+ `(ps ,@args))
\ No newline at end of file
-(in-package :parenscript.javascript)
-
-;;;; The macrology of the basic Javascript-in-SEXPs language. Special forms and macros.
-
-;;; literals
-(defmacro defscriptliteral (name string)
- "Define a Javascript literal that will expand to STRING."
- `(define-script-special-form ,name () (make-instance 'expression :value ,string)))
-
-(defscriptliteral this "this")
-(defscriptliteral t "true")
-(defscriptliteral true "true")
-(defscriptliteral false "false")
-(defscriptliteral f "false")
-(defscriptliteral nil "null")
-(defscriptliteral undefined "undefined")
-
-(defmacro defscriptkeyword (name string)
- "Define a Javascript keyword that will expand to STRING."
- `(define-script-special-form ,name () (make-instance 'statement :value ,string)))
-
-(defscriptkeyword break "break")
-(defscriptkeyword continue "continue")
-
-;;; array literals
-(define-script-special-form array (&rest values)
- (make-instance 'array-literal
- :values (mapcar #'compile-to-expression values)))
-
-(define-script-special-form aref (array &rest coords)
- (make-instance 'js-aref
- :array (compile-to-expression array)
- :index (mapcar #'compile-to-expression coords)))
-
-
-;;; object literals (maps and hash-tables)
-(define-script-special-form {} (&rest values)
- (make-instance 'object-literal
- :values (loop
- for (key value) on values by #'cddr
- collect (cons key (compile-to-expression value)))))
-
-;;; operators
-(define-script-special-form ++ (x)
- (make-instance 'one-op :pre-p nil :op "++"
- :value (compile-to-expression x)))
-
-(define-script-special-form -- (x)
- (make-instance 'one-op :pre-p nil :op "--"
- :value (compile-to-expression x)))
-
-(define-script-special-form incf (x &optional (delta 1))
- (if (eql delta 1)
- (make-instance 'one-op :pre-p t :op "++"
- :value (compile-to-expression x))
- (make-instance 'op-form
- :operator '+=
- :args (mapcar #'compile-to-expression
- (list x delta )))))
-
-(define-script-special-form decf (x &optional (delta 1))
- (if (eql delta 1)
- (make-instance 'one-op :pre-p t :op "--"
- :value (compile-to-expression x))
- (make-instance 'op-form
- :operator '-=
- :args (mapcar #'compile-to-expression
- (list x delta )))))
-
-(define-script-special-form - (first &rest rest)
- (if (null rest)
- (make-instance 'one-op
- :pre-p t
- :op "-"
- :value (compile-to-expression first))
- (make-instance 'op-form
- :operator '-
- :args (mapcar #'compile-to-expression
- (cons first rest)))))
-
-(define-script-special-form not (x)
- (let ((value (compile-to-expression x)))
- (if (and (typep value 'op-form)
- (= (length (op-args value)) 2))
- (let ((new-op (case (operator value)
- (== '!=)
- (< '>=)
- (> '<=)
- (<= '>)
- (>= '<)
- (!= '==)
- (=== '!==)
- (!== '===)
- (t nil))))
- (if new-op
- (make-instance 'op-form :operator new-op
- :args (op-args value))
- (make-instance 'one-op :pre-p t :op "!"
- :value value)))
- (make-instance 'one-op :pre-p t :op "!"
- :value value))))
-
-(define-script-special-form ~ (x)
- (let ((expr (compile-to-expression x)))
- (make-instance 'one-op :pre-p t :op "~" :value expr)))
-
-(define-script-special-form progn (&rest body)
- (make-instance 'js-block :statements (mapcar #'compile-to-statement body)))
-
-(defmethod expression-precedence ((body js-block))
- (if (= (length (block-statements body)) 1)
- (expression-precedence (first (block-statements body)))
- (op-precedence 'comma)))
-
-;;; function definition
-(define-script-special-form %js-lambda (args &rest body)
- (make-instance 'js-lambda
- :args (mapcar #'compile-to-symbol args)
- :body (make-instance 'js-block
- :indent " "
- :statements (mapcar #'compile-to-statement body))))
-
-(define-script-special-form %js-defun (name args &rest body)
- (make-instance 'js-defun
- :name (compile-to-symbol name)
- :args (mapcar #'compile-to-symbol args)
- :body (make-instance 'js-block
- :indent " "
- :statements (mapcar #'compile-to-statement body))))
-
-;;; object creation
-(define-script-special-form create (&rest args)
- (make-instance 'js-object
- :slots (loop for (name val) on args by #'cddr
- collect (let ((name-expr (compile-to-expression name)))
- (assert (or (typep name-expr 'js-variable)
- (typep name-expr 'script-quote)
- (typep name-expr 'string-literal)
- (typep name-expr 'number-literal)))
- (list name-expr (compile-to-expression val))))))
-
-
-(define-script-special-form %js-slot-value (obj slot)
- (if (ps::expand-script-form slot)
- (make-instance 'js-slot-value
- :object (compile-to-expression obj)
- :slot (compile-script-form slot))
- (compile-to-expression obj)))
-
-;;; cond
-(define-script-special-form cond (&rest clauses)
- (make-instance 'js-cond
- :tests (mapcar (lambda (clause) (compile-to-expression (car clause)))
- clauses)
- :bodies (mapcar (lambda (clause) (compile-to-block (cons 'progn (cdr clause)) :indent " "))
- clauses)))
-
-;;; if
-(define-script-special-form if (test then &optional else)
- (make-instance 'js-if :test (compile-to-expression test)
- :then (compile-to-block then :indent " ")
- :else (when else
- (compile-to-block else :indent " "))))
-
-(defmethod expression-precedence ((if js-if))
- (op-precedence 'if))
-
-;;; switch
-(define-script-special-form switch (value &rest clauses)
- (let ((clauses (mapcar #'(lambda (clause)
- (let ((val (first clause))
- (body (cdr clause)))
- (list (if (eql val 'default)
- 'default
- (compile-to-expression val))
- (compile-to-block (cons 'progn body) :indent " "))))
- clauses))
- (check (compile-to-expression value)))
- (make-instance 'js-switch :value check
- :clauses clauses)))
-
-
-;;; assignment
-(defun assignment-op (op)
- (case op
- (+ '+=)
- (~ '~=)
- (\& '\&=)
- (\| '\|=)
- (- '-=)
- (* '*=)
- (% '%=)
- (>> '>>=)
- (^ '^=)
- (<< '<<=)
- (>>> '>>>=)
- (/ '/=)
- (t nil)))
-
-(defun make-js-test (lhs rhs)
- (if (and (typep rhs 'op-form)
- (member lhs (op-args rhs) :test #'script-equal))
- (let ((args-without (remove lhs (op-args rhs)
- :count 1 :test #'script-equal))
- (args-without-first (remove lhs (op-args rhs)
- :count 1 :end 1
- :test #'script-equal))
- (one (list (make-instance 'number-literal :value 1))))
- #+nil
- (format t "OPERATOR: ~S, ARGS-WITHOUT: ~S, ARGS-WITHOUT-FIRST ~S~%"
- (operator rhs)
- args-without
- args-without-first)
- (cond ((and (script-equal args-without one)
- (eql (operator rhs) '+))
- (make-instance 'one-op :pre-p nil :op "++"
- :value lhs))
- ((and (script-equal args-without-first one)
- (eql (operator rhs) '-))
- (make-instance 'one-op :pre-p nil :op "--"
- :value lhs))
- ((and (assignment-op (operator rhs))
- (member (operator rhs)
- '(+ *))
- (script-equal lhs (first (op-args rhs))))
- (make-instance 'op-form
- :operator (assignment-op (operator rhs))
- :args (list lhs (make-instance 'op-form
- :operator (operator rhs)
- :args args-without-first))))
- ((and (assignment-op (operator rhs))
- (script-equal (first (op-args rhs)) lhs))
- (make-instance 'op-form
- :operator (assignment-op (operator rhs))
- :args (list lhs (make-instance 'op-form
- :operator (operator rhs)
- :args (cdr (op-args rhs))))))
- (t (make-instance 'js-setf :lhs lhs :rhsides (list rhs)))))
- (make-instance 'js-setf :lhs lhs :rhsides (list rhs))))
-
-(define-script-special-form setf1% (lhs rhs)
- (make-js-test (compile-to-expression lhs) (compile-to-expression rhs)))
-
-(defmethod expression-precedence ((setf js-setf))
- (op-precedence '=))
-
-;;; defvar
-(define-script-special-form defvar (name &optional value)
- (make-instance 'js-defvar :names (list (compile-to-symbol name))
- :value (when value (compile-to-expression value))))
-
-;;; iteration
-(defun make-for-vars (decls)
- (loop for decl in decls
- for var = (if (atom decl) decl (first decl))
- for init = (if (atom decl) nil (second decl))
- collect (make-instance 'js-defvar :names (list (compile-to-symbol var))
- :value (compile-to-expression init))))
-
-(defun make-for-steps (decls)
- (loop for decl in decls
- when (= (length decl) 3)
- collect (compile-to-expression (third decl))))
-
-(define-script-special-form do (decls termination &rest body)
- (let ((vars (make-for-vars decls))
- (steps (make-for-steps decls))
- (check (compile-to-expression (list 'not (first termination))))
- (body (compile-to-block (cons 'progn body) :indent " ")))
- (make-instance 'js-for
- :vars vars
- :steps steps
- :check check
- :body body)))
-
-(define-script-special-form doeach (decl &rest body)
- (make-instance 'for-each :name (compile-to-symbol (first decl))
- :value (compile-to-expression (second decl))
- :body (compile-to-block (cons 'progn body) :indent " ")))
-
-(define-script-special-form while (check &rest body)
- (make-instance 'js-while
- :check (compile-to-expression check)
- :body (compile-to-block (cons 'progn body) :indent " ")))
-
-;;; with
-(define-script-special-form with (statement &rest body)
- (make-instance 'js-with
- :obj (compile-to-expression statement)
- :body (compile-to-block (cons 'progn body) :indent " ")))
-
-
-;;; try-catch
-(define-script-special-form try (body &rest clauses)
- (let ((body (compile-to-block body :indent " "))
- (catch (cdr (assoc :catch clauses)))
- (finally (cdr (assoc :finally clauses))))
- (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
- (make-instance 'js-try
- :body body
- :catch (when catch (list (compile-to-symbol (caar catch))
- (compile-to-block (cons 'progn (cdr catch))
- :indent " ")))
- :finally (when finally (compile-to-block (cons 'progn finally)
- :indent " ")))))
-;;; regex
-(define-script-special-form regex (regex)
- (make-instance 'regex :value (string regex)))
-
-;;; TODO instanceof
-(define-script-special-form instanceof (value type)
- (make-instance 'js-instanceof
- :value (compile-to-expression value)
- :type (compile-to-expression type)))
-
-;;; single operations
-(defmacro define-parse-script-single-op (name &optional (superclass 'expression))
- (let ((script-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*)))
- `(define-script-special-form ,name (value)
- (make-instance ',script-name :value (compile-to-expression value)))
- ))
-
-(define-parse-script-single-op throw statement)
-(define-parse-script-single-op delete)
-(define-parse-script-single-op void)
-(define-parse-script-single-op typeof)
-(define-parse-script-single-op new)
-
-(define-script-special-form return (&optional value)
- (make-instance 'js-return :value (compile-to-expression value)))
-
-;;; conditional compilation
-(define-script-special-form cc-if (test &rest body)
- (make-instance 'cc-if :test test
- :body (mapcar #'compile-script-form body)))
-
-;;; standard macros
-(defscriptmacro when (test &rest body)
- `(if ,test (progn ,@body)))
-
-(defscriptmacro unless (test &rest body)
- `(if (not ,test) (progn ,@body)))
-
-(defscriptmacro 1- (form)
- `(- ,form 1))
-
-(defscriptmacro 1+ (form)
- `(+ ,form 1))
-
-;;; helper macros
-(define-script-special-form js (&rest body)
- (make-instance 'string-literal
- :value (string-join (js-to-statement-strings
- (compile-script-form (cons 'progn body)) 0) " ")))
-
-(define-script-special-form script-inline (&rest body)
- (make-instance 'string-literal
- :value (concatenate
- 'string
- "javascript:"
- (string-join (js-to-statement-strings
- (compile-script-form (cons 'progn body)) 0) " "))))
-(defscriptmacro parenscript::js-inline (&rest body)
- `(script-inline ,@body))
+(in-package :parenscript)
+
+;;;; The macrology of the basic Javascript-in-SEXPs language. Special forms and macros.
+
+;;; literals
+(defmacro defpsliteral (name string)
+ `(define-ps-special-form ,name (expecting) (list 'js-literal ,string)))
+
+(defpsliteral this "this")
+(defpsliteral t "true")
+(defpsliteral true "true")
+(defpsliteral false "false")
+(defpsliteral f "false")
+(defpsliteral nil "null")
+(defpsliteral undefined "undefined")
+
+(defmacro defpskeyword (name string)
+ `(define-ps-special-form ,name (expecting) (list 'js-keyword ,string)))
+
+(defpskeyword break "break")
+(defpskeyword continue "continue")
+
+(define-ps-special-form array (expecting &rest values)
+ (cons 'array-literal (mapcar (lambda (form) (compile-parenscript-form form :expecting :expression))
+ values)))
+
+(define-ps-special-form aref (expecting array &rest coords)
+ (list 'js-aref (compile-parenscript-form array :expecting :expression)
+ (mapcar (lambda (form)
+ (compile-parenscript-form form :expecting :expression))
+ coords)))
+
+(define-ps-special-form {} (expecting &rest arrows)
+ (cons 'object-literal (loop for (key value) on arrows by #'cddr
+ collect (cons key (compile-parenscript-form value :expecting :expression)))))
+
+;;; operators
+(define-ps-special-form incf (expecting x &optional (delta 1))
+ (if (equal delta 1)
+ (list 'unary-operator "++" (compile-parenscript-form x :expecting :expression) :prefix t)
+ (list 'operator '+= (list (compile-parenscript-form x :expecting :expression)
+ (compile-parenscript-form delta :expecting :expression)))))
+
+(define-ps-special-form decf (expecting x &optional (delta 1))
+ (if (equal delta 1)
+ (list 'unary-operator "--" (compile-parenscript-form x :expecting :expression) :prefix t)
+ (list 'operator '-= (list (compile-parenscript-form x :expecting :expression)
+ (compile-parenscript-form delta :expecting :expression)))))
+
+(define-ps-special-form - (expecting first &rest rest)
+ (if (null rest)
+ (list 'unary-operator "-" (compile-parenscript-form first :expecting :expression) :prefix t)
+ (list 'operator '- (mapcar (lambda (val) (compile-parenscript-form val :expecting :expression))
+ (cons first rest)))))
+
+(define-ps-special-form not (expecting x)
+ (let ((form (compile-parenscript-form x :expecting :expression))
+ (not-op nil))
+ (if (and (eql (first form) 'operator)
+ (= (length (third form)) 2)
+ (setf not-op (case (second form)
+ (== '!=)
+ (< '>=)
+ (> '<=)
+ (<= '>)
+ (>= '<)
+ (!= '==)
+ (=== '!==)
+ (!== '===)
+ (t nil))))
+ (list 'operator not-op (third form))
+ (list 'unary-operator "!" form :prefix t))))
+
+(define-ps-special-form ~ (expecting x)
+ (list 'unary-operator "~" (compile-parenscript-form x :expecting :expressin) :prefix t))
+
+(defun flatten-progns (body)
+ (unless (null body)
+ (if (and (listp (car body))
+ (eql 'progn (caar body)))
+ (append (cdar body) (flatten-progns (cdr body)))
+ (cons (car body) (flatten-progns (cdr body))))))
+
+(define-ps-special-form progn (expecting &rest body)
+ (list 'js-block
+ (if (eql expecting :statement) t nil)
+ (remove nil (mapcar (lambda (form)
+ (compile-parenscript-form form :expecting :statement))
+ (flatten-progns body)))))
+
+;;; function definition
+(define-ps-special-form %js-lambda (expecting args &rest body)
+ (list 'js-lambda (mapcar (lambda (arg)
+ (compile-parenscript-form arg :expecting :symbol))
+ args)
+ (compile-parenscript-form `(progn ,@body))))
+
+(define-ps-special-form %js-defun (expecting name args &rest body)
+ (list 'js-defun (compile-parenscript-form name :expecting :symbol)
+ (mapcar (lambda (val) (compile-parenscript-form val :expecting :symbol)) args)
+ (compile-parenscript-form `(progn ,@body))))
+
+;;; object creation
+(define-ps-special-form create (expecting &rest args)
+ (list 'js-object (loop for (name val) on args by #'cddr collecting
+ (let ((name-expr (compile-parenscript-form name :expecting :expression)))
+ (assert (or (stringp name-expr)
+ (numberp name-expr)
+ (and (listp name-expr)
+ (or (eql 'js-variable (car name-expr))
+ (eql 'script-quote (car name-expr)))))
+ ()
+ "Slot ~s is not one of js-variable, keyword, string or number." name-expr)
+ (list name-expr (compile-parenscript-form val :expecting :expression))))))
+
+(define-ps-special-form %js-slot-value (expecting obj slot)
+ (if (ps::ps-macroexpand slot)
+ (list 'js-slot-value (compile-parenscript-form obj :expecting :expression) (compile-parenscript-form slot))
+ (compile-parenscript-form obj :expecting :expression)))
+
+(define-ps-special-form cond (expecting &rest clauses)
+ (list 'js-cond (mapcar (lambda (clause)
+ (destructuring-bind (test &rest body)
+ clause
+ (list (compile-parenscript-form test :expecting :expression)
+ (mapcar (lambda (form) (compile-parenscript-form form :expecting :statement))
+ body))))
+ clauses)))
+
+(define-ps-special-form if (expecting test then &optional else)
+ (ecase expecting
+ (:statement (list 'js-statement-if (compile-parenscript-form test :expecting :expression)
+ (compile-parenscript-form `(progn ,then))
+ (when else (compile-parenscript-form `(progn ,else)))))
+ (:expression (list 'js-expression-if (compile-parenscript-form test :expecting :expression)
+ (compile-parenscript-form then :expecting :expression)
+ (when else (compile-parenscript-form else :expecting :expression))))))
+
+(define-ps-special-form switch (expecting test-expr &rest clauses)
+ (let ((clauses (mapcar (lambda (clause)
+ (let ((val (car clause))
+ (body (cdr clause)))
+ (list (if (eql val 'default)
+ 'default
+ (compile-parenscript-form val :expecting :expression))
+ (compile-parenscript-form `(progn ,@body)))))
+ clauses))
+ (expr (compile-parenscript-form test-expr :expecting :expression)))
+ (list 'js-switch expr clauses)))
+
+;;; assignment
+(defun assignment-op (op)
+ (case op
+ (+ '+=)
+ (~ '~=)
+ (\& '\&=)
+ (\| '\|=)
+ (- '-=)
+ (* '*=)
+ (% '%=)
+ (>> '>>=)
+ (^ '^=)
+ (<< '<<=)
+ (>>> '>>>=)
+ (/ '/=)
+ (t nil)))
+
+(defun smart-setf (lhs rhs)
+ (if (and (listp rhs)
+ (eql 'operator (car rhs))
+ (member lhs (third rhs) :test #'equalp))
+ (let ((args-without (remove lhs (third rhs) :count 1 :test #'equalp))
+ (args-without-first (remove lhs (third rhs) :count 1 :end 1 :test #'equalp)))
+ (cond ((and (equal (car args-without) 1) (eql (second rhs) '+))
+ (list 'unary-operator "++" lhs :prefix nil))
+ ((and (equal (second args-without-first) 1) (eql (second rhs) '-))
+ (list 'unary-operator "--" lhs :prefix nil))
+ ((and (assignment-op (second rhs))
+ (member (second rhs) '(+ *))
+ (equalp lhs (first (third rhs))))
+ (list 'operator (assignment-op (second rhs))
+ (list lhs (list 'operator (second rhs) args-without-first))))
+ ((and (assignment-op (second rhs)) (equalp (first (third rhs)) lhs))
+ (list 'operator (assignment-op (second rhs))
+ (list lhs (list 'operator (second rhs) (cdr (third rhs))))))
+ (t (list 'js-assign lhs rhs))))
+ (list 'js-assign lhs rhs)))
+
+(define-ps-special-form setf1% (expecting lhs rhs)
+ (smart-setf (compile-parenscript-form lhs :expecting :expression) (compile-parenscript-form rhs :expecting :expression)))
+
+(define-ps-special-form defvar (expecting name &rest value)
+ (append (list 'js-defvar (compile-parenscript-form name :expecting :symbol))
+ (when value
+ (assert (= (length value) 1) () "Wrong number of arguments to defvar: ~s" `(defvar ,name ,@value))
+ (list (compile-parenscript-form (car value) :expecting :expression)))))
+
+;;; iteration
+(defun make-for-vars (decls)
+ (loop for decl in decls
+ for var = (if (atom decl) decl (first decl))
+ for init-value = (if (atom decl) nil (second decl))
+ collect (cons (compile-parenscript-form var :expecting :symbol) (compile-parenscript-form init-value))))
+
+(defun make-for-steps (decls)
+ (loop for decl in decls
+ when (= (length decl) 3)
+ collect (compile-parenscript-form (third decl) :expecting :expression)))
+
+(define-ps-special-form do (expecting decls termination-test &rest body)
+ (let ((vars (make-for-vars decls))
+ (steps (make-for-steps decls))
+ (test (compile-parenscript-form `(not ,(first termination-test)) :expecting :expression))
+ (body (compile-parenscript-form `(progn ,@body))))
+ (list 'js-for vars steps test body)))
+
+(define-ps-special-form doeach (expecting decl &rest body)
+ (list 'js-for-each
+ (compile-parenscript-form (first decl) :expecting :symbol)
+ (compile-parenscript-form (second decl) :expecting :expression)
+ (compile-parenscript-form `(progn ,@body))))
+
+(define-ps-special-form while (expecting test &rest body)
+ (list 'js-while (compile-parenscript-form test :expecting :expression)
+ (compile-parenscript-form `(progn ,@body))))
+
+(define-ps-special-form with (expecting expression &rest body)
+ (list 'js-with (compile-parenscript-form expression :expecting :expression)
+ (compile-parenscript-form `(progn ,@body))))
+
+(define-ps-special-form try (expecting form &rest clauses)
+ (let ((catch (cdr (assoc :catch clauses)))
+ (finally (cdr (assoc :finally clauses))))
+ (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
+ (list 'js-try (compile-parenscript-form `(progn ,form))
+ :catch (when catch (list (compile-parenscript-form (caar catch) :expecting :symbol)
+ (compile-parenscript-form `(progn ,@(cdr catch)))))
+ :finally (when finally (compile-parenscript-form `(progn ,@finally))))))
+
+(define-ps-special-form regex (expecting regex)
+ (list 'js-regex (string regex)))
+
+;;; TODO instanceof
+(define-ps-special-form instanceof (expecting value type)
+ (list 'js-instanceof (compile-parenscript-form value :expecting :expression)
+ (compile-parenscript-form type :expecting :expression)))
+
+;;; single operations
+(mapcar (lambda (op) (eval `(define-ps-special-form ,op (expecting value)
+ (list 'js-named-operator ',op (compile-parenscript-form value)))))
+ '(throw delete void typeof new))
+
+(define-ps-special-form return (expecting &optional value)
+ (list 'js-return (compile-parenscript-form value :expecting :expression)))
+
+;;; conditional compilation
+(define-ps-special-form cc-if (expecting test &rest body)
+ (list 'cc-if test (mapcar #'compile-parenscript-form body)))
+
+;;; standard macros
+(defpsmacro when (test &rest body)
+ `(if ,test (progn ,@body)))
+
+(defpsmacro unless (test &rest body)
+ `(if (not ,test) (progn ,@body)))
+
+(defpsmacro 1- (form)
+ `(- ,form 1))
+
+(defpsmacro 1+ (form)
+ `(+ ,form 1))
+
+;;; helper macros
+(define-ps-special-form js (expecting &rest body)
+ (string-join (ps-print (compile-parenscript-form `(progn ,@body)) 0) " "))
+
+(define-ps-special-form ps-inline (expecting &rest body)
+ (concatenate 'string
+ "javascript:"
+ (string-join (reduce #'append (mapcar (lambda (form)
+ (ps-print (compile-parenscript-form form :expecting :statement)
+ 0))
+ body))
+ ";")
+ ";"))
+
+++ /dev/null
-(in-package :parenscript)
-
-(defgeneric script-equal (compiled-ast-node1 compiled-ast-node2)
- (:documentation "Determines if the AST nodes are equal."))
-
-;;; AST node equality
-(defmethod script-equal ((obj1 list) (obj2 list))
- (and (= (length obj1) (length obj2))
- (every #'script-equal obj1 obj2)))
-
-(defmethod script-equal ((obj1 t) (obj2 t))
- (equal obj1 obj2))
-
-(defmacro defscriptclass (name superclasses slots &rest class-options)
- (let ((slot-names (mapcar #'(lambda (slot) (if (atom slot) slot (first slot))) slots)))
- `(progn
- (defclass ,name ,superclasses
- ,slots ,@class-options)
- (defmethod script-equal ((obj1 ,name) (obj2 ,name))
- (every #'(lambda (slot)
- (script-equal (slot-value obj1 slot)
- (slot-value obj2 slot)))
- ',slot-names)))))
-
-(in-package :parenscript.javascript)
-
-(defgeneric expression-precedence (expression)
- (:documentation "Returns the precedence of an enscript-javascript expression"))
-
-;;;; define Javascript language types
-(defclass statement ()
- ((value :initarg :value :accessor value :initform nil))
- (:documentation "A Javascript entity without a value."))
-
-(defclass expression (statement)
- ()
- (:documentation "A Javascript entity with a value."))
-
-;;; array literals
-(defscriptclass array-literal (expression)
- ((values :initarg :values :accessor array-values)))
-
-(defscriptclass js-aref (expression)
- ((array :initarg :array
- :accessor aref-array)
- (index :initarg :index
- :accessor aref-index)))
-
-;;; object literals (maps and hash-tables)
-(defscriptclass object-literal (expression)
- ((values :initarg :values :accessor object-values)))
-
-;;; string literals
-(defscriptclass string-literal (expression)
- (value))
-
-
-;;; number literals
-(defscriptclass number-literal (expression)
- (value))
-
-;;; variables
-(defscriptclass js-variable (expression)
- (value))
-
-;;; operators
-(defscriptclass op-form (expression)
- ((operator :initarg :operator :accessor operator)
- (args :initarg :args :accessor op-args)))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defparameter *op-precedence-hash* (make-hash-table :test #'equal))
-
- ;;; generate the operator precedences from *OP-PRECEDENCES*
- (let ((precedence 1))
- (dolist (ops '((aref)
- (slot-value)
- (! not ~)
- (* / %)
- (+ -)
- (<< >>)
- (>>>)
- (< > <= >=)
- (in if)
- (eql == != =)
- (=== !==)
- (&)
- (^)
- (\|)
- (\&\& and)
- (\|\| or)
- (setf *= /= %= += -= <<= >>= >>>= \&= ^= \|=)
- (comma)))
- (dolist (op ops)
- (let ((op-name (symbol-name op)))
- (setf (gethash op-name *op-precedence-hash*) precedence)))
- (incf precedence)))
-
- (defun op-precedence (op)
- (gethash (if (symbolp op)
- (symbol-name op)
- op)
- *op-precedence-hash*)))
-
-(defscriptclass one-op (expression)
- ((pre-p :initarg :pre-p
- :initform nil
- :accessor one-op-pre-p)
- (op :initarg :op
- :accessor one-op)))
-
-;;; function calls
-(defscriptclass function-call (expression)
- ((function :initarg :function :accessor f-function)
- (args :initarg :args :accessor f-args)))
-
-(defscriptclass method-call (expression)
- ((method :initarg :method :accessor m-method)
- (object :initarg :object :accessor m-object)
- (args :initarg :args :accessor m-args)))
-
-;;; body forms
-(defscriptclass js-block (expression)
- ((statements :initarg :statements :accessor block-statements)
- (indent :initarg :indent :initform "" :accessor block-indent)))
-
-(defmethod initialize-instance :after ((block js-block) &rest initargs)
- (declare (ignore initargs))
- (let* ((statements (block-statements block))
- (last (last statements))
- (last-stmt (car last)))
- (when (typep last-stmt 'js-block)
- (setf (block-statements block)
- (nconc (butlast statements)
- (block-statements last-stmt))))))
-
-(defscriptclass js-sub-block (js-block)
- (statements indent))
-
-;;; function definition
-(defscriptclass js-lambda (expression)
- ((args :initarg :args :accessor lambda-args)
- (body :initarg :body :accessor lambda-body)))
-
-(defscriptclass js-defun (js-lambda)
- ((name :initarg :name :accessor defun-name)))
-
-;;; object creation
-(defscriptclass js-object (expression)
- ((slots :initarg :slots
- :accessor o-slots)))
-
-(defscriptclass js-slot-value (expression)
- ((object :initarg :object
- :accessor sv-object)
- (slot :initarg :slot
- :accessor sv-slot)))
-
-;;; cond
-(defscriptclass js-cond (expression)
- ((tests :initarg :tests
- :accessor cond-tests)
- (bodies :initarg :bodies
- :accessor cond-bodies)))
-
-(defscriptclass js-if (expression)
- ((test :initarg :test
- :accessor if-test)
- (then :initarg :then
- :accessor if-then)
- (else :initarg :else
- :accessor if-else)))
-
-(defmethod initialize-instance :after ((if js-if) &rest initargs)
- (declare (ignore initargs))
- (when (and (if-then if)
- (typep (if-then if) 'js-sub-block))
- (change-class (if-then if) 'js-block))
- (when (and (if-else if)
- (typep (if-else if) 'js-sub-block))
- (change-class (if-else if) 'js-block)))
-
-;;; switch
-(defscriptclass js-switch (statement)
- ((value :initarg :value :accessor case-value)
- (clauses :initarg :clauses :accessor case-clauses)))
-
-;;; assignment
-
-(defscriptclass js-setf (expression)
- ((lhs :initarg :lhs :accessor setf-lhs)
- (rhsides :initarg :rhsides :accessor setf-rhsides)))
-
-;;; defvar
-(defscriptclass js-defvar (statement)
- ((names :initarg :names :accessor var-names)
- (value :initarg :value :accessor var-value)))
-
-;;; iteration
-(defscriptclass js-for (statement)
- ((vars :initarg :vars :accessor for-vars)
- (steps :initarg :steps :accessor for-steps)
- (check :initarg :check :accessor for-check)
- (body :initarg :body :accessor for-body)))
-
-(defscriptclass for-each (statement)
- ((name :initarg :name :accessor fe-name)
- (value :initarg :value :accessor fe-value)
- (body :initarg :body :accessor fe-body)))
-
-(defscriptclass js-while (statement)
- ((check :initarg :check :accessor while-check)
- (body :initarg :body :accessor while-body)))
-
-;;; with
-(defscriptclass js-with (statement)
- ((obj :initarg :obj :accessor with-obj)
- (body :initarg :body :accessor with-body)))
-
-;;; try-catch
-(defscriptclass js-try (statement)
- ((body :initarg :body :accessor try-body)
- (catch :initarg :catch :accessor try-catch)
- (finally :initarg :finally :accessor try-finally)))
-
-;;; regular expressions
-(defscriptclass regex (expression)
- (value))
-
-;;; conditional compilation
-(defscriptclass cc-if ()
- ((test :initarg :test :accessor cc-if-test)
- (body :initarg :body :accessor cc-if-body)))
-
-;; TODO this may not be the best integrated implementation of
-;; instanceof into the rest of the code
-(defscriptclass js-instanceof (expression)
- ((value)
- (type :initarg :type)))
-
-(defmacro define-js-single-op (name &optional (superclass 'expression))
- (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*)))
- `(progn
- (defscriptclass ,js-name (,superclass)
- (value)))))
-
-(define-js-single-op return statement)
-(define-js-single-op throw statement)
-(define-js-single-op delete)
-(define-js-single-op void)
-(define-js-single-op typeof)
-(define-js-single-op new)
\ No newline at end of file
-(in-package :parenscript.javascript)
-
-(defgeneric js-to-strings (expression start-pos)
- (:documentation "Transform an enscript-javascript expression to a string"))
-
-(defgeneric js-to-statement-strings (code-fragment start-pos)
- (:documentation "Transform an enscript-javascript code fragment to a string"))
-
-;;; indenter
-
-(defun special-append-to-last (form elt)
- (flet ((special-append (form elt)
- (let ((len (length form)))
- (if (and (> len 0)
- (string= (char form (1- len)) elt))
- form
- (concatenate 'string form elt)))))
- (cond ((stringp form)
- (special-append form elt))
- ((consp form)
- (let ((last (last form)))
- (if (stringp (car last))
- (rplaca last (special-append (car last) elt))
- (append-to-last (car last) elt))
- form))
- (t (error "unsupported form ~S" form)))))
-
-(defun dwim-join (value-string-lists max-length
- &key (start "")
- end
- (join-before "")
- join-after
- (white-space (make-string (length start) :initial-element #\Space))
- (separator " ")
- (append-to-last #'append-to-last)
- (collect t))
- #+nil
- (format t "value-string-lists: ~S~%" value-string-lists)
-
- ;;; collect single value-string-lists until line full
-
- (do* ((string-lists value-string-lists (cdr string-lists))
- (string-list (car string-lists) (car string-lists))
- (cur-elt start)
- (is-first t nil)
- (cur-empty t)
- (res nil))
- ((null string-lists)
- (unless cur-empty
- (push cur-elt res))
- (if (null res)
- (list (concatenate 'string start end))
- (progn
- (when end
- (setf (first res)
- (funcall append-to-last (first res) end)))
- (nreverse res))))
- #+nil
- (format t "string-list: ~S~%" string-list)
-
- (when join-after
- (unless (null (cdr string-lists))
- (funcall append-to-last string-list join-after)))
-
- (if (and collect (= (length string-list) 1))
- (progn
- #+nil
- (format t "cur-elt: ~S line-length ~D, max-length ~D, string: ~S~%"
- cur-elt
- (+ (length (first string-list))
- (length cur-elt))
- max-length
- (first string-list))
- (if (or cur-empty
- (< (+ (length (first string-list))
- (length cur-elt)) max-length))
- (setf cur-elt
- (concatenate 'string cur-elt
- (if (or is-first (and cur-empty (string= join-before "")))
- "" (concatenate 'string separator join-before))
- (first string-list))
- cur-empty nil)
- (progn
- (push cur-elt res)
- (setf cur-elt (concatenate 'string white-space
- join-before (first string-list))
- cur-empty nil))))
-
- (progn
- (unless cur-empty
- (push cur-elt res)
- (setf cur-elt white-space
- cur-empty t))
- (setf res (nconc (nreverse
- (cons (concatenate 'string
- cur-elt
- (if (null res)
- "" join-before)
- (first string-list))
- (mapcar #'(lambda (x) (concatenate 'string white-space x))
- (cdr string-list))))
- res))
- (setf cur-elt white-space cur-empty t)))))
-
-(defmethod js-to-strings ((expression expression) start-pos)
- (declare (ignore start-pos))
- (list (princ-to-string (value expression))))
-
-(defmethod js-to-statement-strings ((expression expression) start-pos)
- (js-to-strings expression start-pos))
-
-(defmethod js-to-statement-strings ((statement statement) start-pos)
- (declare (ignore start-pos))
- (list (princ-to-string (value statement))))
-
-(defmethod js-to-strings ((expression script-quote) start-pos)
- (declare (ignore start-pos))
- (list
- (if (eql nil (value expression))
- "null"
- (case (value expression)
- (t (error "Cannot translate quoted value ~S to javascript" (value expression)))))))
-
-;;; array literals
-
-(defmethod js-to-strings ((array array-literal) start-pos)
- (let ((value-string-lists
- (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
- (array-values array)))
- (max-length (- 80 start-pos 2)))
- (dwim-join value-string-lists max-length
- :start "[ " :end " ]"
- :join-after ",")))
-
-(defmethod js-to-strings ((aref js-aref) start-pos)
- (dwim-join (cons (js-to-strings (aref-array aref) start-pos)
- (mapcar #'(lambda (x) (dwim-join (list (js-to-strings x (+ start-pos 2)))
- (- 80 start-pos 2)
- :start "[" :end "]"))
- (aref-index aref)))
- (- 80 start-pos 2) :separator ""
- :white-space " "))
-
-;;; object literals (maps and hash-tables)
-
-(defmethod js-to-strings ((obj object-literal) start-pos)
- (dwim-join
- (loop
- for (key . value) in (object-values obj)
- append (list
- (dwim-join (list (list (format nil "~A:" (js-translate-symbol key)))
- (js-to-strings value (+ start-pos 2)))
- (- 80 start-pos 2)
- :start "" :end "" :join-after "")))
- (- 80 start-pos 2)
- :start "{ " :end " }"
- :join-after ","))
-
-;;; string literals
-
-(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.")
-
-(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*)))
-
-(defmethod js-to-strings ((string string-literal) 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
- 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)))))
-
-;;; variables
-(defgeneric js-translate-symbol (var)
- (:documentation "Given a JS-VARIABLE returns an output
-JavaScript version of it as a string."))
-
-(defmethod js-translate-symbol ((var js-variable))
- (js-translate-symbol (value var)))
-
-(defmethod js-translate-symbol ((var-name symbol))
- (ps::js-translate-symbol-contextually var-name (ps::symbol-script-package var-name) ps::*compilation-environment*))
-
-(defmethod js-to-strings ((v js-variable) start-form)
- (declare (ignore start-form))
- (list (js-translate-symbol v)))
-
-;;; arithmetic operators
-(defun script-convert-op-name (op)
- (case op
- (and '\&\&)
- (or '\|\|)
- (not '!)
- (eql '\=\=)
- (= '\=\=)
- (t op)))
-
-(defun op-form-p (form)
- (and (listp form)
- (not (script-special-form-p form))
- (not (null (op-precedence (first form))))))
-
-(defun klammer (string-list)
- (prepend-to-first string-list "(")
- (append-to-last string-list ")")
- string-list)
-
-(defmethod expression-precedence ((expression expression))
- 0)
-
-(defmethod expression-precedence ((form op-form))
- (op-precedence (operator form)))
-
-(defmethod js-to-strings ((form op-form) start-pos)
- (let* ((precedence (expression-precedence form))
- (value-string-lists
- (mapcar #'(lambda (x)
- (let ((string-list (js-to-strings x (+ start-pos 2))))
- (if (>= (expression-precedence x) precedence)
- (klammer string-list)
- string-list)))
- (op-args form)))
- (max-length (- 80 start-pos 2))
- (op-string (format nil "~A " (operator form))))
- (dwim-join value-string-lists max-length :join-before op-string)
- ))
-
-(defmethod js-to-strings ((one-op one-op) start-pos)
- (let* ((value (value one-op))
- (value-strings (js-to-strings value start-pos)))
- (when (typep value 'op-form)
- (setf value-strings (klammer value-strings)))
- (if (one-op-pre-p one-op)
- (prepend-to-first value-strings
- (one-op one-op))
- (append-to-last value-strings
- (one-op one-op)))))
-
-;;; function calls
-
-(defmethod js-to-strings ((form function-call) start-pos)
- (let* ((value-string-lists
- (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
- (f-args form)))
- (max-length (- 80 start-pos 2))
- (args (dwim-join value-string-lists max-length
- :start "(" :end ")" :join-after ",")))
- (etypecase (f-function form)
- (js-lambda
- (dwim-join (list (append (dwim-join (list (js-to-strings (f-function form) (+ start-pos 2)))
- max-length
- :start "(" :end ")" :separator "")
- args))
- max-length
- :separator ""))
- ((or js-variable js-aref js-slot-value)
- (dwim-join (list (js-to-strings (f-function form) (+ start-pos 2))
- args)
- max-length
- :separator ""))
- (function-call
- ;; TODO it adds superfluous newlines after each ()
- ;; and it's nearly the same as the js-lambda case above
- (dwim-join (list (append (dwim-join (list (js-to-strings (f-function form) (+ start-pos 2)))
- max-length :separator "")
- args))
- max-length :separator "")))))
-
-(defmethod js-to-strings ((form method-call) start-pos)
- (let ((object (js-to-strings (m-object form) (+ start-pos 2))))
- ;; TODO: this may not be the best way to add ()'s around lambdas
- ;; probably there is or should be a more general solution working
- ;; in other situations involving lambda's
- (when (member (m-object form) (list 'js-lambda 'number-literal 'js-object 'op-form)
- :test #'typep)
- (push "(" object)
- (nconc object (list ")")))
- (let* ((fname (dwim-join (list object
- (list (js-translate-symbol (m-method form))))
- (- 80 start-pos 2)
- :end "("
- :separator ""))
- (butlast (butlast fname))
- (last (car (last fname)))
- (method-and-args (dwim-join (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
- (m-args form))
- (- 80 start-pos 2)
- :start last
- :end ")"
- :join-after ","))
- (ensure-no-newline-before-dot (concatenate 'string
- (car (last butlast))
- (first method-and-args))))
- (nconc (butlast butlast)
- (list ensure-no-newline-before-dot)
- (rest method-and-args)))))
-
-;;; optimization that gets rid of nested blocks, which have no meaningful effect
-;;; in javascript
-(defgeneric expanded-subblocks (block)
- (:method (block)
- (list block))
- (:method ((block js-block))
- (mapcan #'expanded-subblocks (block-statements block))))
-
-(defun consolidate-subblocks (block)
- (setf (block-statements block) (expanded-subblocks block))
- block)
-
-
-(defmethod js-to-statement-strings ((body js-block) start-pos)
- (consolidate-subblocks body)
- (dwim-join (mapcar #'(lambda (x) (js-to-statement-strings x (+ start-pos 2)))
- (block-statements body))
- (- 80 start-pos 2)
- :join-after ";"
- :append-to-last #'special-append-to-last
- :start (block-indent body) :collect nil
- :end ";"))
-
-(defmethod js-to-strings ((body js-block) start-pos)
- (dwim-join (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
- (block-statements body))
- (- 80 start-pos 2)
- :append-to-last #'special-append-to-last
- :join-after ","
- :start (block-indent body)))
-
-
-(defmethod js-to-statement-strings ((body js-sub-block) start-pos)
- (declare (ignore start-pos))
- (nconc (list "{") (call-next-method) (list "}")))
-
-;;; function definition
-(defmethod js-to-strings ((lambda js-lambda) start-pos)
- (let ((fun-header (dwim-join (mapcar #'(lambda (x)
- (list (js-translate-symbol x)))
- (lambda-args lambda))
- (- 80 start-pos 2)
- :start (function-start-string lambda)
- :end ") {" :join-after ","))
- (fun-body (js-to-statement-strings (lambda-body lambda) (+ start-pos 2))))
- (nconc fun-header fun-body (list "}"))))
-
-(defgeneric function-start-string (function)
- (:documentation "Returns the string that starts the function - this varies according to whether
-this is a lambda or a defun"))
-
-(defmethod function-start-string ((lambda js-lambda))
- "function (")
-
-(defmethod js-to-statement-strings ((lambda js-lambda) start-pos)
- (js-to-strings lambda start-pos))
-
-(defmethod function-start-string ((defun js-defun))
- (format nil "function ~A(" (js-translate-symbol (defun-name defun))))
-
-;;; object creation
-(defmethod js-to-strings ((object js-object) start-pos)
- (let ((value-string-lists
- (mapcar #'(lambda (slot)
- (let* ((slot-name (first slot))
- (slot-string-name
- (if (typep slot-name 'script-quote)
- (if (symbolp (value slot-name))
- (format nil "~A" (js-translate-symbol (value slot-name)))
- (format nil "~A" (first (js-to-strings slot-name 0))))
- (car (js-to-strings slot-name 0)))))
- (dwim-join (list (js-to-strings (second slot) (+ start-pos 4)))
- (- 80 start-pos 2)
- :start (concatenate 'string slot-string-name " : ")
- :white-space " ")))
- (o-slots object)))
- (max-length (- 80 start-pos 2)))
- (dwim-join value-string-lists max-length
- :start "{ "
- :end " }"
- :join-after ", "
- :white-space " "
- :collect nil)))
-
-(defmethod js-to-strings ((sv js-slot-value) start-pos)
- (append-to-last (if (typep (sv-object sv) 'js-variable)
- (js-to-strings (sv-object sv) start-pos)
- (list (format nil "~A" (js-to-strings (sv-object sv) start-pos))))
- (if (typep (sv-slot sv) 'script-quote)
- (if (symbolp (value (sv-slot sv)))
- (format nil ".~A" (js-translate-symbol (value (sv-slot sv))))
- (format nil ".~A" (first (js-to-strings (sv-slot sv) 0))))
- (format nil "[~A]" (first (js-to-strings (sv-slot sv) 0))))))
-
-;;; cond
-(defmethod js-to-statement-strings ((cond js-cond) start-pos)
- (loop :for body :on (cond-bodies cond)
- :for first = (eq body (cond-bodies cond))
- :for last = (not (cdr body))
- :for test :in (cond-tests cond)
- :append (if (and last (not first) (string= (value test) "true"))
- '("else {")
- (dwim-join (list (js-to-strings test 0)) (- 80 start-pos 2)
- :start (if first "if (" "else if (") :end ") {"))
- :append (js-to-statement-strings (car body) (+ start-pos 2))
- :collect "}"))
-
-(defmethod js-to-statement-strings ((if js-if) start-pos)
- (let ((if-strings (dwim-join (list (js-to-strings (if-test if) 0))
- (- 80 start-pos 2)
- :start "if ("
- :end ") {"))
- (then-strings (js-to-statement-strings (if-then if) (+ start-pos 2)))
- (else-strings (when (if-else if)
- (js-to-statement-strings (if-else if)
- (+ start-pos 2)))))
- (nconc if-strings then-strings (if else-strings
- (nconc (list "} else {") else-strings (list "}"))
- (list "}")))))
-
-(defmethod js-to-strings ((if js-if) start-pos)
- (assert (typep (if-then if) 'expression))
- (when (if-else if)
- (assert (typep (if-else if) 'expression)))
- (dwim-join (list (append-to-last (js-to-strings (if-test if) start-pos) " ?")
- (let* ((new-then (make-instance 'js-block
- :statements (block-statements (if-then if))
- :indent ""))
- (res (js-to-strings new-then start-pos)))
- (if (>= (expression-precedence (if-then if))
- (expression-precedence if))
- (klammer res)
- res))
- (list ":")
- (if (if-else if)
- (let* ((new-else (make-instance 'js-block
- :statements (block-statements (if-else if))
- :indent ""))
- (res (js-to-strings new-else start-pos)))
- (if (>= (expression-precedence (if-else if))
- (expression-precedence if))
- (klammer res)
- res))
- (list "undefined")))
- (- 80 start-pos 2)
- :white-space " "))
-
-;;; setf
-(defmethod js-to-strings ((setf js-setf) start-pos)
- (dwim-join (cons (js-to-strings (setf-lhs setf) start-pos)
- (mapcar #'(lambda (x) (js-to-strings x start-pos)) (setf-rhsides setf)))
- (- 80 start-pos 2)
- :join-after " ="))
-
-;;; defvar
-(defmethod js-to-statement-strings ((defvar js-defvar) start-pos)
- (dwim-join (nconc (mapcar #'(lambda (x) (list (js-translate-symbol x))) (var-names defvar))
- (when (var-value defvar)
- (list (js-to-strings (var-value defvar) start-pos))))
- (- 80 start-pos 2)
- :join-after " ="
- :start "var " :end ";"))
-
-;;; iteration
-(defmethod js-to-statement-strings ((for js-for) start-pos)
- (let* ((init (dwim-join (mapcar #'(lambda (x)
- (dwim-join (list (list (js-translate-symbol (first (var-names x))))
- (js-to-strings (var-value x)
- (+ start-pos 2)))
- (- 80 start-pos 2)
- :join-after " ="))
- (for-vars for))
- (- 80 start-pos 2)
- :start "var " :join-after ","))
- (check (js-to-strings (for-check for) (+ start-pos 2)))
- (steps (dwim-join (mapcar #'(lambda (x var)
- (dwim-join
- (list (list (js-translate-symbol (first (var-names var))))
- (js-to-strings x (- start-pos 2)))
- (- 80 start-pos 2)
- :join-after " ="))
- (for-steps for)
- (for-vars for))
- (- 80 start-pos 2)
- :join-after ","))
- (header (dwim-join (list init check steps)
- (- 80 start-pos 2)
- :start "for (" :end ") {"
- :join-after ";"))
- (body (js-to-statement-strings (for-body for) (+ start-pos 2))))
- (nconc header body (list "}"))))
-
-
-(defmethod js-to-statement-strings ((fe for-each) start-pos)
- (let ((header (dwim-join (list (list (js-translate-symbol (fe-name fe)))
- (list "in")
- (js-to-strings (fe-value fe) (+ start-pos 2)))
- (- 80 start-pos 2)
- :start "for (var "
- :end ") {"))
- (body (js-to-statement-strings (fe-body fe) (+ start-pos 2))))
- (nconc header body (list "}"))))
-
-(defmethod js-to-statement-strings ((while js-while) start-pos)
- (let ((header (dwim-join (list (js-to-strings (while-check while) (+ start-pos 2)))
- (- 80 start-pos 2)
- :start "while ("
- :end ") {"))
- (body (js-to-statement-strings (while-body while) (+ start-pos 2))))
- (nconc header body (list "}"))))
-
-;;; with
-(defmethod js-to-statement-strings ((with js-with) start-pos)
- (nconc (dwim-join (list (js-to-strings (with-obj with) (+ start-pos 2)))
- (- 80 start-pos 2)
- :start "with (" :end ") {")
- (js-to-statement-strings (with-body with) (+ start-pos 2))
- (list "}")))
-
-;;; switch
-(defmethod js-to-statement-strings ((case js-switch) start-pos)
- (let ((body (mapcan #'(lambda (clause)
- (let ((val (car clause))
- (body (second clause)))
- (dwim-join (list (if (eql val 'default)
- (list "")
- (js-to-strings val (+ start-pos 2)))
- (js-to-statement-strings body (+ start-pos 2)))
- (- 80 start-pos 2)
- :start (if (eql val 'default) " default" " case ")
- :white-space " "
- :join-after ":"))) (case-clauses case))))
- (nconc (dwim-join (list (js-to-strings (case-value case) (+ start-pos 2)))
- (- 80 start-pos 2)
- :start "switch (" :end ") {")
- body
- (list "}"))))
-
-;;; try-catch
-(defmethod js-to-statement-strings ((try js-try) start-pos)
- (let* ((catch (try-catch try))
- (finally (try-finally try))
- (catch-list (when catch
- (nconc
- (dwim-join (list (list (js-translate-symbol (first catch))))
- (- 80 start-pos 2)
- :start "} catch ("
- :end ") {")
- (js-to-statement-strings (second catch) (+ start-pos 2)))))
- (finally-list (when finally
- (nconc (list "} finally {")
- (js-to-statement-strings finally (+ start-pos 2))))))
- (nconc (list "try {")
- (js-to-statement-strings (try-body try) (+ start-pos 2))
- catch-list
- finally-list
- (list "}"))))
-
-;;; 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
-(defmethod js-to-statement-strings ((cc cc-if) start-pos)
- (nconc (list (format nil "/*@if ~A" (cc-if-test cc)))
- (mapcan #'(lambda (x) (js-to-strings x start-pos)) (cc-if-body cc))
- (list "@end @*/")))
-
-
-;;; TODO instanceof
-(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)
- :start "("
- :end ")"
- :white-space
- " "))
-
-;;; single operations
-(defmacro define-translate-js-single-op (name &optional (superclass 'expression))
- (let ((script-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*)))
- `(defmethod ,(if (eql superclass 'expression)
- 'js-to-strings
- 'js-to-statement-strings)
- ((,name ,script-name) start-pos)
- (dwim-join (list (js-to-strings (value ,name) (+ start-pos 2)))
- (- 80 start-pos 2)
- :start ,(concatenate 'string (string-downcase (symbol-name name)) " ")
- :white-space " "))))
-
-(define-translate-js-single-op return statement)
-(define-translate-js-single-op throw statement)
-(define-translate-js-single-op delete)
-(define-translate-js-single-op void)
-(define-translate-js-single-op typeof)
-(define-translate-js-single-op new)
\ No newline at end of file
+(in-package :parenscript)
+
+(defgeneric ps-print% (special-form-name special-form-args %start-pos%))
+
+(defmacro defprinter (special-form content-args &body body)
+ "Given a special-form name and a destructuring lambda-list for its
+arguments, defines a printer for that form using the given body."
+ (let ((sf (gensym))
+ (sf-args (gensym)))
+ `(defmethod ps-print% ((,sf (eql ',special-form)) ,sf-args %start-pos%)
+ (declare (ignore ,sf))
+ (destructuring-bind ,content-args
+ ,sf-args
+ ,@body))))
+
+(defvar %start-pos%)
+
+(defgeneric ps-print (compiled-form %start-pos%))
+
+(defmethod ps-print ((compiled-form cons) %start-pos%)
+ "Prints the given compiled ParenScript form starting at the given
+indent position."
+ (ps-print% (car compiled-form) (cdr compiled-form) %start-pos%))
+
+;;; string literals
+(defvar *js-quote-char* #\'
+ "Specifies which character JS should use for delimiting strings.
+
+This variable is useful when have to embed some javascript code
+in an html attribute delimited by #\\\" as opposed to #\\', or
+vice-versa.")
+
+(defparameter *js-lisp-escaped-chars*
+ '((#\' . #\')
+ (#\\ . #\\)
+ (#\b . #\Backspace)
+ (#\f . #.(code-char 12))
+ (#\n . #\Newline)
+ (#\r . #\Return)
+ (#\t . #\Tab)))
+
+(defmethod ps-print ((string string) %start-pos%)
+ (flet ((lisp-special-char-to-js (lisp-char)
+ (car (rassoc lisp-char *js-lisp-escaped-chars*))))
+ (list (with-output-to-string (escaped)
+ (write-char *js-quote-char* escaped)
+ (loop for char across 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))))))
+
+(defmethod ps-print ((number number) %start-pos%)
+ (list (format nil (if (integerp number) "~S" "~F") number)))
+
+;;; expression and operator precedence rules
+
+(defun expression-precedence (expr)
+ (if (consp expr)
+ (case (car expr)
+ (js-block (if (= (length (cdr expr)) 1)
+ (expression-precedence (first (cdr expr)))
+ (op-precedence 'comma)))
+ (js-expression-if (op-precedence 'js-expression-if))
+ (js-assign (op-precedence '=))
+ (operator (op-precedence (second expr)))
+ (otherwise 0))
+ 0))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *op-precedence-hash* (make-hash-table :test #'equal))
+
+ ;;; generate the operator precedences from *OP-PRECEDENCES*
+ (let ((precedence 1))
+ (dolist (ops '((js-aref)
+ (js-slot-value)
+ (! not ~)
+ (* / %)
+ (+ -)
+ (<< >>)
+ (>>>)
+ (< > <= >=)
+ (in js-expression-if)
+ (eql == != =)
+ (=== !==)
+ (&)
+ (^)
+ (\|)
+ (\&\& and)
+ (\|\| or)
+ (js-assign *= /= %= += -= <<= >>= >>>= \&= ^= \|=)
+ (comma)))
+ (dolist (op ops)
+ (let ((op-name (symbol-name op)))
+ (setf (gethash op-name *op-precedence-hash*) precedence)))
+ (incf precedence)))
+
+ (defun op-precedence (op)
+ (gethash (if (symbolp op)
+ (symbol-name op)
+ op)
+ *op-precedence-hash*)))
+
+;;; indenter
+
+(defmacro max-length () '(- 80 %start-pos% 2))
+
+(defun ps-print-indent (ps-form)
+ (ps-print ps-form (+ %start-pos% 2)))
+
+(defun special-append-to-last (form elt)
+ (flet ((special-append (form elt)
+ (let ((len (length form)))
+ (if (and (> len 0)
+ (string= (char form (1- len)) elt))
+ form
+ (concatenate 'string form elt)))))
+ (cond ((stringp form)
+ (special-append form elt))
+ ((consp form)
+ (let ((last (last form)))
+ (if (stringp (car last))
+ (rplaca last (special-append (car last) elt))
+ (append-to-last (car last) elt))
+ form))
+ (t (error "Wrong argument type to indent appender: ~S" form)))))
+
+(defun dwim-join (value-string-lists max-length
+ &key (start "")
+ end
+ (join-before "")
+ join-after
+ (white-space (make-string (length start) :initial-element #\Space))
+ (separator " ")
+ (append-to-last #'append-to-last)
+ (collect t))
+ #+nil
+ (format t "value-string-lists: ~S~%" value-string-lists)
+
+ ;;; collect single value-string-lists until the line is full
+
+ (do* ((string-lists value-string-lists (cdr string-lists))
+ (string-list (car string-lists) (car string-lists))
+ (cur-elt start)
+ (is-first t nil)
+ (cur-empty t)
+ (res nil))
+ ((null string-lists)
+ (unless cur-empty
+ (push cur-elt res))
+ (if (null res)
+ (list (concatenate 'string start end))
+ (progn
+ (when end
+ (setf (first res)
+ (funcall append-to-last (first res) end)))
+ (nreverse res))))
+ #+nil
+ (format t "string-list: ~S~%" string-list)
+
+ (when join-after
+ (unless (null (cdr string-lists))
+ (funcall append-to-last string-list join-after)))
+
+ (if (and collect (= (length string-list) 1))
+ (progn
+ #+nil
+ (format t "cur-elt: ~S line-length ~D, max-length ~D, string: ~S~%"
+ cur-elt
+ (+ (length (first string-list))
+ (length cur-elt))
+ max-length
+ (first string-list))
+ (if (or cur-empty
+ (< (+ (length (first string-list))
+ (length cur-elt)) max-length))
+ (setf cur-elt
+ (concatenate 'string cur-elt
+ (if (or is-first (and cur-empty (string= join-before "")))
+ "" (concatenate 'string separator join-before))
+ (first string-list))
+ cur-empty nil)
+ (progn
+ (push cur-elt res)
+ (setf cur-elt (concatenate 'string white-space
+ join-before (first string-list))
+ cur-empty nil))))
+
+ (progn
+ (unless cur-empty
+ (push cur-elt res)
+ (setf cur-elt white-space
+ cur-empty t))
+ (setf res (nconc (nreverse
+ (cons (concatenate 'string
+ cur-elt
+ (if (null res)
+ "" join-before)
+ (first string-list))
+ (mapcar #'(lambda (x) (concatenate 'string white-space x))
+ (cdr string-list))))
+ res))
+ (setf cur-elt white-space cur-empty t)))))
+
+(defprinter script-quote (val)
+ (if (null val)
+ (list "null")
+ (error "Cannot translate quoted value ~S to javascript" val)))
+
+(defprinter js-literal (str)
+ (list str))
+
+(defprinter js-keyword (str)
+ (list str))
+
+;;; array literals
+
+(defprinter array-literal (&rest initial-contents)
+ (let ((initial-contents-strings (mapcar #'ps-print-indent initial-contents)))
+ (dwim-join initial-contents-strings (max-length)
+ :start "[ " :end " ]"
+ :join-after ",")))
+
+(defprinter js-aref (array coords)
+ (dwim-join (cons (ps-print array %start-pos%)
+ (mapcar (lambda (x) (dwim-join (list (ps-print-indent x))
+ (max-length)
+ :start "[" :end "]"))
+ coords))
+ (max-length)
+ :white-space " "
+ :separator ""))
+
+(defprinter object-literal (&rest arrows)
+ (dwim-join (loop for (key . value) in arrows appending
+ (list (dwim-join (list (list (format nil "~A:" (js-translate-symbol key)))
+ (ps-print-indent value))
+ (max-length)
+ :start "" :end "" :join-after "")))
+ (max-length)
+ :start "{ " :end " }"
+ :join-after ","))
+
+(defprinter js-variable (var)
+ (list (js-translate-symbol var)))
+
+;;; arithmetic operators
+(defun script-convert-op-name (op)
+ (case op
+ (and '\&\&)
+ (or '\|\|)
+ (not '!)
+ (eql '\=\=)
+ (= '\=\=)
+ (t op)))
+
+(defun parenthesize (string-list)
+ (prepend-to-first string-list "(")
+ (append-to-last string-list ")")
+ string-list)
+
+(defprinter operator (op args)
+ (let* ((precedence (op-precedence op))
+ (arg-strings (mapcar (lambda (arg)
+ (let ((arg-strings (ps-print-indent arg)))
+ (if (>= (expression-precedence arg) precedence)
+ (parenthesize arg-strings)
+ arg-strings)))
+ args))
+ (op-string (format nil "~A " op)))
+ (dwim-join arg-strings (max-length) :join-before op-string)))
+
+(defprinter unary-operator (op arg &key prefix)
+ (let ((arg-string (ps-print arg %start-pos%)))
+ (when (eql 'operator (car arg))
+ (setf arg-string (parenthesize arg-string)))
+ (if prefix
+ (prepend-to-first arg-string op)
+ (append-to-last arg-string op))))
+
+;;; function and method calls
+(defprinter js-funcall (fun-designator args)
+ (let* ((arg-strings (mapcar #'ps-print-indent args))
+ (args (dwim-join arg-strings (max-length)
+ :start "(" :end ")" :join-after ",")))
+ (cond ((eql 'js-lambda (car fun-designator))
+ (dwim-join (list (append (dwim-join (list (ps-print-indent fun-designator))
+ (max-length)
+ :start "(" :end ")" :separator "")
+ args))
+ (max-length)
+ :separator ""))
+ ((member (car fun-designator) '(js-variable js-aref js-slot-value))
+ (dwim-join (list (ps-print-indent fun-designator) args)
+ (max-length)
+ :separator ""))
+ ((eql 'js-funcall (car fun-designator))
+ ;; TODO it adds superfluous newlines after each ()
+ ;; and it's nearly the same as the js-lambda case above
+ (dwim-join (list (append (dwim-join (list (ps-print-indent fun-designator))
+ (max-length) :separator "")
+ args))
+ (max-length) :separator "")))))
+
+(defprinter js-method-call (method object args)
+ (let ((printed-object (ps-print object (+ %start-pos% 2))))
+ ;; TODO: this may not be the best way to add ()'s around lambdas
+ ;; probably there is or should be a more general solution working
+ ;; in other situations involving lambda's
+ (when (or (numberp object) (and (consp object) (member (car object) '(js-lambda js-object operator))))
+ (setf printed-object (append (list "(") printed-object (list ")"))))
+ (let* ((fname (dwim-join (list printed-object (list (js-translate-symbol method)))
+ (max-length)
+ :end "("
+ :separator ""))
+ (butlast (butlast fname))
+ (last (car (last fname)))
+ (method-and-args (dwim-join (mapcar #'ps-print-indent args)
+ (max-length)
+ :start last
+ :end ")"
+ :join-after ","))
+ (ensure-no-newline-before-dot (concatenate 'string
+ (car (last butlast))
+ (first method-and-args))))
+ (append (butlast butlast) (list ensure-no-newline-before-dot) (cdr method-and-args)))))
+
+(defprinter js-block (statement-p statements)
+ (dwim-join (mapcar #'ps-print-indent statements)
+ (max-length)
+ :join-after (if statement-p ";" ",")
+ :append-to-last #'special-append-to-last
+ :start (if statement-p " " "")
+ :collect nil
+ :end (if statement-p ";" "")))
+
+(defprinter js-lambda (args body)
+ (print-fun-def nil args body %start-pos%))
+
+(defprinter js-defun (name args body)
+ (print-fun-def name args body %start-pos%))
+
+(defun print-fun-def (name args body %start-pos%)
+ (let ((fun-header (dwim-join (mapcar (lambda (x) (list (js-translate-symbol x)))
+ args)
+ (max-length)
+ :start (format nil "function ~:[~;~A~](" name (js-translate-symbol name))
+ :join-after ","
+ :end ") {"))
+ (fun-body (ps-print-indent body)))
+ (append fun-header fun-body (list "}"))))
+
+;;; object creation
+(defprinter js-object (slot-defs)
+ (let ((value-string-lists (mapcar (lambda (slot)
+ (let* ((slot-name (first slot))
+ (slot-string-name
+ (if (and (listp slot-name) (eql 'script-quote (car slot-name)))
+ (format nil "~A" (if (symbolp (second slot-name))
+ (js-translate-symbol (second slot-name))
+ (car (ps-print slot-name 0))))
+ (car (ps-print slot-name 0)))))
+ (dwim-join (list (ps-print (second slot) (+ %start-pos% 4)))
+ (max-length)
+ :start (concatenate 'string slot-string-name " : ")
+ :white-space " ")))
+ slot-defs)))
+ (dwim-join value-string-lists (max-length)
+ :start "{ "
+ :end " }"
+ :join-after ", "
+ :white-space " "
+ :collect nil)))
+
+(defprinter js-slot-value (obj slot)
+ (append-to-last (if (eql 'js-variable (car obj))
+ (ps-print obj %start-pos%)
+ (list (format nil "~A" (ps-print obj %start-pos%))))
+ (if (eql 'script-quote (car slot))
+ (format nil ".~A" (if (symbolp (second slot))
+ (js-translate-symbol (second slot))
+ (first (ps-print slot 0))))
+ (format nil "[~A]" (first (ps-print slot 0))))))
+
+;;; cond
+(defprinter js-cond (clauses)
+ (loop for (test body-forms) in clauses
+ for start = "if (" then "else if ("
+ append (if (string= test "true")
+ '("else {")
+ (dwim-join (list (ps-print test 0)) (max-length)
+ :start start :end ") {"))
+ append (mapcar #'ps-print-indent body-forms)
+ collect "}"))
+
+(defprinter js-statement-if (test then else)
+ (let ((if-strings (dwim-join (list (ps-print test 0))
+ (- 80 %start-pos% 2)
+ :start "if ("
+ :end ") {"))
+ (then-strings (ps-print-indent then))
+ (else-strings (when else
+ (ps-print-indent else))))
+ (append if-strings then-strings (if else-strings
+ (append (list "} else {") else-strings (list "}"))
+ (list "}")))))
+
+(defprinter js-expression-if (test then else)
+ (dwim-join (list (append-to-last (ps-print test %start-pos%) " ?")
+ (let ((then-string (ps-print then %start-pos%)))
+ (if (>= (expression-precedence then) (op-precedence 'js-expression-if))
+ (parenthesize then-string)
+ then-string))
+ (list ":")
+ (if else
+ (let ((else-string (ps-print else %start-pos%)))
+ (if (>= (expression-precedence else) (op-precedence 'js-expression-if))
+ (parenthesize else-string)
+ else-string))
+ (list "undefined")))
+ (max-length)
+ :white-space " "))
+
+(defprinter js-assign (lhs rhs)
+ (dwim-join (list (ps-print lhs %start-pos%) (ps-print rhs %start-pos%))
+ (max-length)
+ :join-after " ="))
+
+(defprinter js-defvar (var-name &rest var-value)
+ (dwim-join (append (list (list (js-translate-symbol var-name)))
+ (when var-value
+ (list (ps-print (car var-value) %start-pos%))))
+ (max-length)
+ :join-after " ="
+ :start "var " :end ";"))
+
+;;; iteration
+(defprinter js-for (vars steps test body-block)
+ (let* ((init (dwim-join (mapcar (lambda (var-form)
+ (dwim-join (list (list (js-translate-symbol (car var-form)))
+ (ps-print-indent (cdr var-form)))
+ (max-length)
+ :join-after " ="))
+ vars)
+ (max-length)
+ :start "var " :join-after ","))
+ (test-string (ps-print-indent test))
+ (step-strings (dwim-join (mapcar (lambda (x var-form)
+ (dwim-join
+ (list (list (js-translate-symbol (car var-form)))
+ (ps-print x (- %start-pos% 2)))
+ (max-length)
+ :join-after " ="))
+ steps
+ vars)
+ (max-length)
+ :join-after ","))
+ (header (dwim-join (list init test-string step-strings)
+ (max-length)
+ :start "for (" :end ") {"
+ :join-after ";"))
+ (body (ps-print-indent body-block)))
+ (append header body (list "}"))))
+
+(defprinter js-for-each (var object body-block)
+ (let ((header (dwim-join (list (list (js-translate-symbol var))
+ (list "in")
+ (ps-print-indent object))
+ (max-length)
+ :start "for (var "
+ :end ") {"))
+ (body (ps-print-indent body-block)))
+ (append header body (list "}"))))
+
+(defprinter js-while (test body-block)
+ (let ((header-strings (dwim-join (list (ps-print-indent test))
+ (max-length)
+ :start "while ("
+ :end ") {"))
+ (body-strings (ps-print-indent body-block)))
+ (append header-strings body-strings (list "}"))))
+
+(defprinter js-with (expression body-block)
+ (append (dwim-join (list (ps-print-indent expression))
+ (max-length)
+ :start "with (" :end ") {")
+ (ps-print-indent body-block)
+ (list "}")))
+
+(defprinter js-switch (test clauses)
+ (let ((body-strings (mapcar (lambda (clause)
+ (let ((val (first clause))
+ (body-block (second clause)))
+ (dwim-join (list (if (eql val 'default)
+ (list "")
+ (ps-print-indent val))
+ (ps-print-indent body-block))
+ (max-length)
+ :start (if (eql val 'default) " default" " case ")
+ :white-space " "
+ :join-after ":")))
+ clauses)))
+ (append (dwim-join (list (ps-print-indent test))
+ (max-length)
+ :start "switch (" :end ") {")
+ (reduce #'append body-strings)
+ (list "}"))))
+
+(defprinter js-try (body &key catch finally)
+ (let ((catch-strings (when catch
+ (append (dwim-join (list (list (js-translate-symbol (first catch))))
+ (max-length)
+ :start "} catch ("
+ :end ") {")
+ (ps-print-indent (second catch)))))
+ (finally-strings (when finally
+ (append (list "} finally {")
+ (ps-print-indent finally)))))
+ (append (list "try {")
+ (ps-print-indent body)
+ catch-strings
+ finally-strings
+ (list "}"))))
+
+;;; regex
+(defprinter js-regex (regex)
+ (flet ((first-slash-p (string)
+ (and (> (length string) 0) (eql (char string 0) '#\/))))
+ (let ((slash (unless (first-slash-p regex) "/")))
+ (list (format nil (concatenate 'string slash "~A" slash) regex)))))
+
+(defprinter js-return (value)
+ (let ((printed-value (ps-print value 0)))
+ (cons (concatenate 'string "return " (car printed-value)) (cdr printed-value))))
+
+;;; conditional compilation
+(defprinter cc-if (test body-forms)
+ (append (list (format nil "/*@if ~A" test))
+ (mapcar (lambda (x) (ps-print x %start-pos%)) body-forms)
+ (list "@end @*/")))
+
+;;; TODO instanceof
+(defprinter js-instanceof (value type)
+ (dwim-join (list (ps-print-indent value)
+ (list "instanceof")
+ (ps-print-indent type))
+ (max-length)
+ :start "("
+ :end ")"
+ :white-space " "))
+
+(defprinter js-named-operator (op value)
+ (dwim-join (list (ps-print-indent value))
+ (max-length)
+ :start (concatenate 'string (string-downcase (symbol-name op)) " ")
+ :white-space " "))
(map nil #'handle-form forms))
(cons '+ (optimize-string-list (nreverse res)))))
-(define-script-special-form html (&rest forms)
- (compile-script-form (process-html-forms forms)))
+(define-ps-special-form html (expecting &rest forms)
+ (compile-parenscript-form (process-html-forms forms)))
-(defun process-css-forms(proplist)
+(defun process-css-forms (proplist)
(optimize-string-list (butlast
(loop for propval on proplist by #'cddr appending
- (list (string-downcase ( symbol-name (first propval)))
+ (list (string-downcase (symbol-name (first propval)))
":"
(second propval)
";")))))
-(define-script-special-form css-inline (&rest forms)
- (compile-script-form (cons '+ (process-css-forms forms))))
+(define-ps-special-form css-inline (expecting &rest forms)
+ (compile-parenscript-form (cons '+ (process-css-forms forms))))
;;; Handy utilities for doing common tasks found in many web browser
;;; JavaScript implementations
-(defscriptmacro do-set-timeout ((timeout) &body body)
+(defpsmacro do-set-timeout ((timeout) &body body)
`(set-timeout (lambda () ,@body) ,timeout))
;;; Arithmetic
(defmacro def-js-maths (&rest mathdefs)
- `(progn ,@(mapcar (lambda (def) (cons 'defscriptmacro def)) mathdefs)))
+ `(progn ,@(mapcar (lambda (def) (cons 'defpsmacro def)) mathdefs)))
(def-js-maths
(min (&rest nums) `(*math.min ,@nums))
;;; Exception handling
-(defscriptmacro ignore-errors (&body body)
+(defpsmacro ignore-errors (&body body)
`(try (progn ,@body) (:catch (e))))
;;; Misc
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; ParenScript package system
-
-(in-package :parenscript)
-
-(defclass script-package ()
- ;; configuration slots
- ((name :accessor script-package-name :initform nil :initarg :name :type string
- :documentation "Canonical name of the package (a String).")
- (nicknames :accessor script-package-nicknames :initform nil :initarg :nicknames
- :documentation "List of nicknames for the package (as strings).")
- (prefix :accessor script-package-prefix :initform nil :initarg :prefix :type string
- :documentation "The prefix string that will be used when translating the symbols in the current package to Javascript.")
- (lisp-package :accessor script-package-lisp-package :initform nil :initarg :lisp-package)
- (secondary-lisp-packages :accessor script-package-secondary-lisp-packages :initform nil
- :initarg :secondary-lisp-packages)
- (exports :accessor script-package-exports :initarg :exports
- :initform nil;(make-hash-table :test #'equal)
- :documentation "List of exported identifiers.")
- (used-packages :accessor script-package-used-packages :initform nil :initarg :used-packages
- :documentation "")
- (documentation :accessor script-package-documentation :initform nil :initarg :documentation)
- (compilation-env :accessor script-package-comp-env :initform nil :initarg :comp-env)
- (locked? :accessor script-package-locked? :initform nil :initarg :locked?
- :documentation "t if redefinition of top-level symbols is disallowed.")
- ;; internal use slots
- (symbol-table :accessor script-package-symbol-table :initform nil :initarg :symbol-table
- :documentation "Contains symbols when there is no lisp package for this package.")
- )
- (:documentation "A Parenscript package is a lisp object that holds information
-about a set of code.
-
-"))
-
-(defmethod print-object ((sp script-package) stream)
- (format stream "#<SCRIPT-PACKAGE ~s>" (script-package-name sp)))
-
-(defclass compilation-environment ()
- ((script-packages :accessor comp-env-script-packages :initform nil :initarg :packages
- :documentation "List of packages defined in this environment.")
- (current-package :accessor comp-env-current-package :initform nil :initarg :current-package
- :documentation "Current in-package.")
- (lisp-to-script-package-table
- :accessor comp-env-lisp-to-script-package-table :initform (make-hash-table)
- :documentation "Maps a lisp package to a script package.")
- (compiling-toplevel-p
- :accessor comp-env-compiling-toplevel-p :initform nil :initarg :processing-toplevel-p
- :documentation "T if the environment is currently processing toplevel forms.")
- (symbol-table :accessor symbol-to-script-package :initform (make-hash-table)
- :documentation "Maps symbols to script packages. Used for only the
-symbols in script packages that do not have a primary lisp package."))
- (:documentation ""))
-
-(defgeneric symbol-script-package (symbol)
- (:documentation "Gets the Parenscript package associated with a Lisp/Parenscript symbol."))
-
-(defvar *warn-ps-package* nil
- "If true, warns when ParenScript attempts to compile symbols that
-don't have an associated ParenScript package.")
-
-(defun lisp-to-script-package (lisp-package &optional (comp-env *compilation-environment*))
- "Gets a script package corresponding to the given Lisp package."
- (gethash lisp-package (comp-env-lisp-to-script-package-table comp-env)))
-
-(defsetf lisp-to-script-package (lisp-package &optional (comp-env *compilation-environment*))
- (script-package)
- "Sets the script package corresponding to the given Lisp package."
- `(setf (gethash ,lisp-package (comp-env-lisp-to-script-package-table ,comp-env))
- ,script-package))
-
-(defmethod symbol-script-package ((symbol symbol))
- (if (symbol-package symbol)
- (or (lisp-to-script-package (symbol-package symbol) *compilation-environment*)
- (progn (when *warn-ps-package*
- (warn 'simple-style-warning
- :format-control "~s is a symbol with lisp package ~s, which has no corresponding ParenScript package.
-Defaulting to :parenscript-user."
- :format-arguments (list symbol (symbol-package symbol))))
- (find-script-package "PARENSCRIPT-USER" (make-basic-compilation-environment))))
- (find-script-package "UNINTERNED" *compilation-environment*)))
-
-(defun find-script-package (name &optional (comp-env *compilation-environment*))
- "Find the script package with the name NAME in the given compilation environment."
- (typecase name
- ((or symbol string)
- (find-if #'(lambda (script-package)
- (find (string name)
- (cons (script-package-name script-package)
- (script-package-nicknames script-package))
- :test #'equal))
- (comp-env-script-packages comp-env)))
- (script-package name)
- (t (error "~A has unknown type" name))))
-
-(defun script-intern (name script-package-name)
- "Returns a Parenscript symbol with the string value STRING interned for the
-given SCRIPT-PACKAGE."
- (declare (type string name))
- (let ((script-package (find-script-package script-package-name)))
- (flet ((find-exported-symbol (name script-package)
- (let ((res
- (find name (script-package-exports script-package)
- :key #'(lambda (exported-symbol) (string exported-symbol))
- :test #'equal)))
- res)))
- (let ((res
- (or
- (some #'(lambda (used-package)
- (find-exported-symbol name used-package))
- (script-package-used-packages script-package))
- (if (script-package-lisp-package script-package)
- (intern name (script-package-lisp-package script-package))
- (progn
- (let ((sym (intern-without-package name)))
- (setf (gethash name (script-package-symbol-table script-package))
- sym)
- (setf (gethash sym (symbol-to-script-package (script-package-comp-env script-package)))
- script-package)
- sym))))))
- (declare (type symbol res))
- res))))
-
-(defun find-script-symbol (name script-package)
- "Finds the symbol with name NAME in the script package SCRIPT-PACKAGE. NAME is a
-string and SCRIPT-PACKAGE is a package designator. If NAME does not specify a symbol of
-script-package, returns nil. Otherwise returns 2 values:
-1. the symbol
-2. :external if the symbol is external. :internal if the symbol is internal. NIL if
-the symbol is not interned in the package."
- (setf script-package (find-script-package script-package))
- (let (symbol interned-p)
-
- (if (script-package-lisp-package script-package)
- (multiple-value-bind (lisp-symbol lisp-status)
- (find-symbol name (script-package-lisp-package script-package))
- (setf symbol lisp-symbol)
- (setf interned-p (and lisp-status t)))
- (multiple-value-bind (sym sym-found-p)
- (gethash name (script-package-symbol-table script-package))
- (setf symbol sym)
- (setf interned-p sym-found-p)))
- (let ((exported? (member symbol (script-package-exports script-package))))
- (values symbol
- (if exported? :external (if interned-p :internal nil))))))
-
-(defun script-export (symbols
- &optional (script-package (comp-env-current-package *compilation-environment*)))
- "Exports the given symbols in the given script package."
- (when (not (listp symbols)) (setf symbols (list symbols)))
- (setf script-package (find-script-package script-package))
- (let ((symbols-not-in-package
- (remove-if #'(lambda (symbol)
- (declare (type symbol symbol))
- (eql symbol (find-script-symbol (string symbol) script-package)))
- symbols)))
- (when symbols-not-in-package
- (error "Invalid exports. The following symbols are not interned in the package ~A:~%~A"
- (script-package-name script-package) symbols-not-in-package)))
- (mapc #'(lambda (symbol)
- (pushnew symbol (script-package-exports script-package)))
- symbols)
- t)
-
-(defun use-script-package (packages-to-use
- &optional (into-package (comp-env-current-package *compilation-environment*)))
- "use-script-package causes INTO-PACKAGE to inherit all the external symbols of packages-to-use.
-The inherited symbols become accessible as internal symbols of package."
- (when (not (listp packages-to-use)) (setf packages-to-use (list packages-to-use)))
- (setf packages-to-use (mapcar #'find-script-package packages-to-use))
- (setf into-package (find-script-package into-package))
-
- (let ((all-used-symbols (apply #'append (mapcar #'script-package-exports packages-to-use))))
- (mapc #'(lambda (used-symbol)
- (let ((symbol-same-name (find-script-symbol (string used-symbol) into-package)))
- (when (not (or (null symbol-same-name)
- (eql symbol-same-name used-symbol)))
- (error "Import of symbol ~A into package ~A conflicts with interned symbol ~A"
- used-symbol (script-package-name into-package) symbol-same-name))))
- all-used-symbols))
- (setf (script-package-used-packages into-package)
- (append (script-package-used-packages into-package) packages-to-use)))
-
-(defun intern-without-package (name)
- (macrolet ((with-temp-package ((var) &body body)
- (let ((result-var (gensym)))
- `(let* ((,var (make-package ',(gensym)))
- (,result-var (progn ,@body)))
- (delete-package ,var)
- ,result-var))))
- (with-temp-package (package)
- (let ((sym (intern name package)))
- (unintern sym package)
- sym))))
-
-(defun create-script-package (comp-env
- &key name nicknames prefix secondary-lisp-packages used-packages
- lisp-package exports documentation)
- "Creates a script package in the given compilation environment"
- (when (and lisp-package (not (find-package lisp-package)))
- (error "Package ~A does not exists" lisp-package))
- (let* ((script-package
- (make-instance 'script-package
- :name (string name)
- :comp-env comp-env
- :prefix prefix
- :nicknames (mapcar #'string nicknames)
- :lisp-package (when lisp-package (find-package lisp-package))
- :secondary-lisp-packages (mapcar #'find-package secondary-lisp-packages)
- :documentation documentation)))
- (use-script-package used-packages script-package)
- (labels ((package-intern (string-like)
- (script-intern (string string-like) script-package)))
- (script-export (mapcar #'package-intern exports) script-package))
- (push script-package (comp-env-script-packages comp-env))
- script-package))
-
-(defmethod initialize-instance :after ((package script-package) &key)
- (assert (script-package-comp-env package))
- (when (null (script-package-lisp-package package))
- (setf (script-package-symbol-table package)
- (make-hash-table :test #'equal)))
- (let ((lisp-packages
- (remove-if #'null
- (cons (script-package-lisp-package package)
- (script-package-secondary-lisp-packages package)))))
- (dolist (lisp-package lisp-packages)
- (when (lisp-to-script-package lisp-package (script-package-comp-env package))
- (error "Lisp package already has corresponding script package: ~A" (package-name lisp-package)))
- (setf (lisp-to-script-package lisp-package (script-package-comp-env package))
- package))))
-
-(defgeneric comp-env-find-package (comp-env package-designator)
- (:documentation "Finds the script package named by PACKAGE-DESIGNATOR in the current
-compilation environment. PACKAGE-DESIGNATOR is a string or symbol.")
- (:method ((comp-env compilation-environment) (name string))
- (find name (comp-env-script-packages comp-env)
- :key #'script-package-name :test #'equal))
- (:method ((comp-env compilation-environment) (package-designator symbol))
- (comp-env-find-package comp-env (string package-designator))))
-
-;; TODO loop through all defined macros and add them to the script package's
-;; macro environment
-; (labels ((name-member (name)
-; (eql (script-package-lisp-package script-package) (symbol-package name)))
-; (import-macro (name function)
-; (when (name-member name)
-; (setf (gethash name (script-package-macro-table script-package))
-; function)))
-; (import-special-form (name function)
-; (when (name-member name)
-; (setf (gethash name (script-package-special-form-table script-package))
-; function))))
-; (maphash #'import-special-form *toplevel-special-forms*)
-; (maphash #'import-special-form *toplevel-special-forms*)
-
-;(defgeneric comp-env-select-package (comp-env script-package)
-; (:documentation "")
-; (:method ((comp-env compilation-environment) (package script-package))
-; (setf (comp-env-current-package
-
-
-(defvar *enable-package-system* nil)
-
-;;; Interface for reading in identifier
-
-(defgeneric lisp-symbol-to-ps-identifier (symbol context &optional compilation-environment)
- (:documentation "Context is one of :special-form, :macro or nil."))
-
-(defmethod lisp-symbol-to-ps-identifier ((symbol symbol) (context (eql :special-form)) &optional comp-ev)
- (declare (ignore context comp-ev))
- (symbol-name symbol))
-
-(defmethod lisp-symbol-to-ps-identifier ((symbol symbol) (context (eql :macro)) &optional comp-ev)
- (declare (ignore context comp-ev))
- symbol)
-
-(defmethod lisp-symbol-to-ps-identifier :around ((symbol symbol) context &optional comp-ev)
- (declare (ignore context comp-ev))
- (if *enable-package-system*
- (call-next-method)
- (symbol-name symbol)))
-
-;;; Symbol obfuscation (this should really go somewhere else)
-(defvar *obfuscate-standard-identifiers* nil)
-
-(defparameter *obfuscation-table* (make-hash-table))
-
-(defun obfuscated-symbol (symbol)
- (or (gethash symbol *obfuscation-table*)
- (setf (gethash symbol *obfuscation-table*) (string (gensym)))))
-
-;;; Interface for printing identifiers
-
-(defvar *package-prefix-style* :prefix
- "Determines how package symbols are serialized to JavaScript identifiers. NIL for
-no prefixes. :prefix to prefix variables with something like packagename_identifier.")
-
-(defgeneric js-translate-symbol-contextually (symbol package env)
- (:documentation "Translates a symbol to a string in the given environment & package
-and for the given symbol."))
-
-(defmethod js-translate-symbol-contextually ((symbol symbol) (package ps::script-package) (env ps::compilation-environment))
- (cond ((member (ps::script-package-lisp-package package) (mapcar #'find-package '(:keyword :parenscript.global)))
- (symbol-to-js symbol))
- (*obfuscate-standard-identifiers* (obfuscated-symbol symbol))
- (t (if (and *enable-package-system* (eql *package-prefix-style* :prefix))
- (format nil "~A~A"
- (or (ps::script-package-prefix package) (concatenate 'string (ps::script-package-name package) "_"))
- (symbol-to-js symbol))
- (symbol-to-js symbol)))))
-
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; ParenScript namespace system
+
+(in-package :parenscript)
+
+(defun lisp-symbol-to-ps-identifier (symbol context)
+ (case context
+ (:special-form (symbol-name symbol))
+ (:macro symbol)
+ (otherwise (symbol-name symbol))))
+
+;;; Symbol obfuscation
+(defvar *obfuscate-identifiers* nil)
+
+(defparameter *obfuscation-table* (make-hash-table))
+
+(defun obfuscated-symbol (symbol)
+ (or (gethash symbol *obfuscation-table*)
+ (setf (gethash symbol *obfuscation-table*) (string (gensym)))))
+
+;;; Interface for printing identifiers
+
+(defvar *package-prefix-style* :prefix
+ "Determines how package symbols are serialized to JavaScript identifiers. NIL for
+no prefixes. :prefix to prefix variables with something like packagename_identifier.")
+
+(defvar *package-prefix-table* (make-hash-table))
+
+(defmacro ps-package-prefix (package)
+ "Place for storing a string to be prefixed to any symbols in the
+designated package when translating ParenScript code."
+ `(gethash (find-package ,package) *package-prefix-table*))
+
+(defun js-translate-symbol (symbol)
+ (cond (*obfuscate-identifiers* (obfuscated-symbol symbol))
+ ((and (eql *package-prefix-style* :prefix) (ps-package-prefix (symbol-package symbol)))
+ (format nil "~A~A" (ps-package-prefix (symbol-package symbol)) (symbol-to-js symbol)))
+ (t (symbol-to-js symbol))))
+
"Symbols exported from both the Parenscript and Javascript packages
that are also valid as Parenscript symbols for the corresponding script packages."))
-(defpackage parenscript.javascript
- (:use :common-lisp)
- (:nicknames javascript ps-js)
- #.(cons :export *shared-symbols-ps-js*)
- (:export
- ;; function definition
- #:%js-defun
- #:%js-lambda
- #:%js-slot-value
- ;; translate
- #:js-to-strings
- #:js-to-statement-strings
- )
- (:documentation "The package used to define Javascript special forms. Most of Parenscript
-is defined as macros on top of Javascript special forms"))
-
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *parenscript-lang-exports*
(append
*shared-symbols-ps-js*
'(
- ;; package system
- #:defpackage
- #:in-package
-
;; function definition
#:defun
#:lambda
#:with-slots
#:slot-value
- ;; eval-when
- #:eval-when
;; macros
#:macrolet
#:symbol-macrolet
both the Lisp package and the script package for Parenscript."))
(defpackage :parenscript
- (:use :common-lisp :parenscript.javascript)
+ (:use :common-lisp)
(:nicknames :js :ps)
#.(cons :export *shared-symbols-ps-js*)
#.(cons :export *parenscript-lang-exports*)
(:export
;; compiler
#:compile-script
- #:script
- #:script*
#:ps
#:ps*
- #:js
- #:js*
- #:with-new-compilation-environment ; tentative
- #:with-compilation-environment ; tentative
- #:*compilation-environment*
-
- ;; package system
- #:find-script-package
- #:script-intern
- #:script-export
- #:find-script-symbol
- #:comp-env-current-package
- #:symbol-script-package
- #:script-package-name
;; for parenscript macro definition within lisp
- #:defscriptmacro
- #:defpsmacro ; should we use one or the other of these?
+ #:defpsmacro
#:defmacro/ps
#:defmacro+ps
#:import-macros-from-lisp
;; gensym
- #:with-unique-ps-names
- #:gen-script-name
- #:gen-script-name-string
- #:gen-ps-name
+ #:ps-gensym
+ #:with-ps-gensyms
+ #:*ps-gensym-counter*
;; deprecated interface
#:gen-js-name
#:js-file
#:js-script
#:js-to-statement-strings
+ #:js
+ #:js*
))
-(in-package :parenscript)
-(import
- '(defscriptclass
- define-script-special-form
- defscriptmacro
- symbol-to-js
- script-quote
- *package-prefix-style*
- *script-macro-env*
- compile-to-statement
- compile-to-block
- compile-to-symbol
- compile-to-expression
- symbol-script-package
- script-package-name
- list-join
- list-to-string
- append-to-last
- prepend-to-first
- string-join
- val-to-string
- string-split
- script-special-form-p
- make-macro-env-dictionary
- script-equal
- compile-script-form
- )
- :parenscript.javascript)
-
-(defpackage parenscript.global
- (:nicknames "GLOBAL")
- (:documentation "Symbols interned in the global package are serialized in Javascript
-as non-prefixed identifiers."))
-
-(defpackage parenscript.user
- (:use :parenscript)
- (:nicknames ps-user parenscript-user)
- (:documentation "The default package a user is inside of when compiling code."))
-
-(defpackage parenscript.non-prefixed (:nicknames ps.non-prefixed))
-(defpackage parenscript.ps-gensyms)
(in-package :parenscript)
;;;; The mechanisms for defining macros & parsing Parenscript.
-(defgeneric compiler-in-situation-p (comp-env situation)
- (:documentation "Returns true when the compiler is considered 'in' the situation
-given by SITUATION, which is one of :compile-toplevel :execute.")
- (:method ((comp-env compilation-environment) situation)
- (cond
- ((eql situation :compile-toplevel) (processing-toplevel-p comp-env))
- ((eql situation :execute) (not (processing-toplevel-p comp-env)))
- (t nil))))
-
-(defgeneric processing-toplevel-p (comp-env)
- (:documentation "T if we are compiling TOPLEVEL forms, as in
-http://www.lispworks.com/documentation/HyperSpec/Body/03_bca.htm")
- (:method ((comp-env compilation-environment))
- (comp-env-compiling-toplevel-p comp-env)
- ))
-
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *toplevel-special-forms* (make-hash-table :test #'equal)
"A hash-table containing functions that implement Parenscript special forms,
indexed by name (as symbols)")
- (defun undefine-script-special-form (name)
+ (defun undefine-ps-special-form (name)
"Undefines the special form with the given name (name is a symbol)."
(remhash (lisp-symbol-to-ps-identifier name :special-form) *toplevel-special-forms*)))
-(defmacro define-script-special-form (name lambda-list &rest body)
- "Define a special form NAME. Arguments are destructured according to
-LAMBDA-LIST. The resulting Parenscript language types are appended to the
-ongoing javascript compilation."
+(defmacro define-ps-special-form (name lambda-list &rest body)
+ "Define a special form NAME. The first argument given to the special
+form is a keyword indicating whether the form is expected to produce
+an :expression or a :statement. The resulting Parenscript language
+types are appended to the ongoing javascript compilation."
(let ((arglist (gensym "ps-arglist-")))
`(setf (gethash (lisp-symbol-to-ps-identifier ',name :special-form) *toplevel-special-forms*)
(lambda (&rest ,arglist)
,arglist
,@body)))))
-(defun get-script-special-form (name)
+(defun get-ps-special-form (name)
"Returns the special form function corresponding to the given name."
(gethash (lisp-symbol-to-ps-identifier name :special-form) *toplevel-special-forms*))
-;;; sexp form predicates
-(defun script-special-form-p (form)
- "Returns T if FORM is a special form and NIL otherwise."
+;;; ParenScript form predicates
+(defun ps-special-form-p (form)
(and (consp form)
(symbolp (car form))
- (get-script-special-form (car form))))
+ (get-ps-special-form (car form))))
+
+(defun op-form-p (form)
+ (and (listp form)
+ (not (ps-special-form-p form))
+ (not (null (op-precedence (first form))))))
(defun funcall-form-p (form)
(and (listp form)
- (not (ps-js::op-form-p form))
- (not (script-special-form-p form))))
+ (not (op-form-p form))
+ (not (ps-special-form-p form))))
(defun method-call-p (form)
(and (funcall-form-p form)
(defun define-script-macro% (name args body &key symbol-macro-p)
(let ((lambda-list (gensym "ps-lambda-list-"))
(body (if (and (cdr body) (stringp (first body))) (rest body) body))) ;; drop docstring
- (undefine-script-special-form name)
+ (undefine-ps-special-form name)
(setf (get-macro-spec name *script-macro-toplevel*)
(cons symbol-macro-p (compile nil `(lambda (&rest ,lambda-list)
(destructuring-bind ,args
,@body)))))
nil)))
-(defmacro defscriptmacro (name args &body body)
+(defmacro defpsmacro (name args &body body)
"Define a ParenScript macro, and store it in the toplevel ParenScript
macro environment."
`(define-script-macro% ',name ',args ',body :symbol-macro-p nil))
that macro in Lisp makes the Lisp macro unsuitable to be imported into
the ParenScript macro environment."
`(progn (defmacro ,name ,args ,@body)
- (defscriptmacro ,name ,args ,@body)))
-
-(defmacro defpsmacro (&rest args)
- `(defscriptmacro ,@args))
-
-(defun expand-script-form (expr)
- "Expands a Parenscript form until it reaches a special form. Returns 2 values:
-1. the expanded form.
-2. whether the form was expanded."
- (if (consp expr)
- (let ((op (car expr))
- (args (cdr expr)))
+ (defpsmacro ,name ,args ,@body)))
+
+(defun ps-macroexpand (form)
+ "Recursively macroexpands ParenScript macros and symbol-macros in
+the given ParenScript form. Returns two values: the expanded form, and
+whether any expansion was performed on the form or not."
+ (if (consp form)
+ (let ((op (car form))
+ (args (cdr form)))
(cond ((equal op 'quote)
(values
- (if (equalp '(nil) args) nil expr) ;; leave quotes alone, unless it's a quoted nil
+ (if (equalp '(nil) args) nil form) ;; leave quotes alone, unless it's a quoted nil
nil))
((script-macro-p op) ;; recursively expand parenscript macros in parent env.
(multiple-value-bind (expansion-function macro-env)
(lookup-macro-expansion-function op)
(values
- (expand-script-form (let ((*script-macro-env* macro-env))
+ (ps-macroexpand (let ((*script-macro-env* macro-env))
(apply expansion-function args)))
t)))
- ((script-special-form-p expr)
- (values expr nil))
- (t (values expr nil))))
- (cond ((script-symbol-macro-p expr)
+ (t (values form nil))))
+ (cond ((script-symbol-macro-p form)
;; recursively expand symbol macros in parent env.
(multiple-value-bind (expansion-function macro-env)
- (lookup-macro-expansion-function expr)
+ (lookup-macro-expansion-function form)
(values
- (expand-script-form (let ((*script-macro-env* macro-env))
+ (ps-macroexpand (let ((*script-macro-env* macro-env))
(funcall expansion-function)))
t)))
;; leave anything else alone
- (t (values expr nil)))))
-
-(defun process-eval-when-args (args)
- "(eval-when form-language? (situation*) form*) - returns 3 values:
-form-language, a list of situations, and a list of body forms"
- (let* ((rest args)
- (form-language
- (when (not (listp (first rest)))
- (setf rest (rest args))
- (first args)))
- (situations (first rest))
- (body (rest rest)))
- (when (and (find :compile-toplevel situations) (find :execute situations))
- (error "Cannot use EVAL-WHEN to execute COMPILE-TOPLEVEL and EXECUTE code simultaneously."))
- (when (null form-language)
- (setf form-language
- (cond
- ((find :compile-toplevel situations) :lisp)
- ((find :execute situations) :parenscript))))
- (values form-language situations body)))
-
-;;;; compiler interface ;;;;
-(defgeneric compile-parenscript-form (compilation-environment form)
- (:documentation "Compiles FORM, which is a ParenScript form.
-If toplevel-p is NIL, the result is a compilation object (the AST root).
-Subsequently TRANSLATE-AST can be called to convert the result to Javascript.
-
-If the compiler is in the COMPILE-TOPLEVEL stage, then the result will
-be a Parenscript form (after it has been processed according to semantics
-like those of Lisp's COMPILE-FILE). See
-http://www.lispworks.com/documentation/HyperSpec/Body/03_bca.htm"))
-
-(defgeneric compile-toplevel-parenscript-form (comp-env form)
- (:documentation "Compiles a parenscript form in the given compilation environment
-when the environment is in the :compile-toplevel situation. Returns a form to be
-compiled in place of the original form upon exiting the :compile-toplevel situation."))
-
-(defmethod compile-toplevel-parenscript-form ((comp-env compilation-environment) form)
- (cond
- ((not (listp form)) form)
- ;; process each clause of a progn as a toplevel form
- ((eql 'progn (car form))
- `(progn
- ,@(mapcar #'(lambda (subform)
- (compile-parenscript-form comp-env subform))
- (rest form))))
- ;; TODO process macrolets, symbol-macrolets, and file inclusions
-
- ;; process eval-when. evaluates in :COMPILE-TOPLEVEL situation and returns
- ;; the resultant form. for :EXECUTE situation it returns
- ((eql 'eval-when (car form))
- (multiple-value-bind (body-language situations body)
- (process-eval-when-args (rest form))
- (cond
- ((find :compile-toplevel situations)
- (when (eql body-language :lisp)
- (let ((other-situations (remove :compile-toplevel situations)))
- (multiple-value-bind (function warnings-p failure-p)
- (compile nil `(lambda () ,@body))
- (declare (ignore warnings-p) (ignore failure-p))
- (compile-parenscript-form
- comp-env
- `(progn
- ,(funcall function)
- ,@(when other-situations
- (list `(eval-when ,other-situations ,@body)))))))))
- ;; if :compile-toplevel is not in the situation list, return the form
- (t form))))
- (t form)))
-
-
-(defmethod compile-parenscript-form :around ((comp-env compilation-environment) form)
- (multiple-value-bind (expanded-form expanded-p)
- (expand-script-form form)
- (cond
- (expanded-p
- (compile-parenscript-form comp-env expanded-form))
- ((comp-env-compiling-toplevel-p comp-env)
- (compile-toplevel-parenscript-form comp-env form))
- (t (call-next-method)))))
-
-(defmethod compile-parenscript-form ((comp-env compilation-environment) (form string))
- (make-instance 'ps-js::string-literal :value form))
-
-(defmethod compile-parenscript-form ((comp-env compilation-environment) (form character))
- (compile-parenscript-form comp-env (string form)))
-
-(defmethod compile-parenscript-form ((comp-env compilation-environment) (form number))
- (make-instance 'ps-js::number-literal :value form))
-
-(defmethod compile-parenscript-form ((comp-env compilation-environment) (form symbol))
+ (t (values form nil)))))
+
+;;;; compiler interface
+(defgeneric compile-parenscript-form (form &key expecting)
+ (:documentation "Compiles a ParenScript form to the intermediate
+ParenScript representation. :expecting determines whether the form is
+compiled to an :expression (the default), a :statement, or a
+:symbol."))
+
+(defmethod compile-parenscript-form :around (form &key expecting)
+ (if (eql expecting :symbol)
+ (compile-to-symbol form)
+ (multiple-value-bind (expanded-form expanded-p)
+ (ps-macroexpand form)
+ (if expanded-p
+ (compile-parenscript-form expanded-form)
+ (call-next-method)))))
+
+(defun compile-to-symbol (form)
+ "Compiles the given Parenscript form and guarantees that the
+resultant symbol has an associated script-package. Raises an error if
+the form cannot be compiled to a symbol."
+ (let ((exp (compile-parenscript-form form)))
+ (when (or (eql (first exp) 'js-variable)
+ (eql (first exp) 'script-quote))
+ (setf exp (second exp)))
+ (assert (symbolp exp) ()
+ "~a is expected to be a symbol, but compiles to ~a (the ParenScript output for ~a alone is \"~a\"). This could be due to ~a being a special form." form exp form (ps* form) form)
+ exp))
+
+(defmethod compile-parenscript-form (form &key expecting)
+ (declare (ignore expecting))
+ (error "The object ~S cannot be compiled by ParenScript." form))
+
+(defmethod compile-parenscript-form ((form number) &key expecting)
+ (declare (ignore expecting))
+ form)
+
+(defmethod compile-parenscript-form ((form string) &key expecting)
+ (declare (ignore expecting))
+ form)
+
+(defmethod compile-parenscript-form ((form character) &key expecting)
+ (declare (ignore expecting))
+ (compile-parenscript-form (string form)))
+
+(defmethod compile-parenscript-form ((symbol symbol) &key expecting)
+ (declare (ignore expecting))
;; is this the correct behavior?
- (let ((c-macro (get-script-special-form form)))
- (cond
- (c-macro (funcall c-macro))
- ;; the following emulates the lisp behavior that a keyword is bound to itself
- ;; see http://clhs.lisp.se/Body/t_kwd.htm
- ((keywordp form) (compile-parenscript-form comp-env `(quote ,form)))
- (t (make-instance 'ps-js::js-variable :value form)))))
-
-(defun compile-function-argument-forms (forms)
+ (let ((special-symbol (get-ps-special-form symbol)))
+ (cond (special-symbol (funcall special-symbol :symbol))
+ ;; the following emulates the lisp behavior that a keyword is bound to itself
+ ;; see http://clhs.lisp.se/Body/t_kwd.htm
+ ((keywordp symbol) (compile-parenscript-form `(quote ,symbol)))
+ (t (list 'js-variable symbol)))))
+
+(defun compile-function-argument-forms (arg-forms)
"Compiles a bunch of Parenscript forms from a funcall form to an effective set of
Javascript arguments. The only extra processing this does is makes :keyword arguments
into a single options argument via CREATE."
(flet ((keyword-arg (arg)
"If the given compiled expression is supposed to be a keyword argument, returns
the keyword for it."
- (when (typep arg 'script-quote) (ps-js::value arg))))
- (let ((expressions (mapcar #'compile-to-expression forms)))
-
- (do ((effective-expressions nil)
- (expressions-subl expressions))
-
- ((not expressions-subl)
- (nreverse effective-expressions))
-
- (let ((arg-expr (first expressions-subl)))
- (if (keyword-arg arg-expr)
- (progn
- (when (oddp (length expressions-subl))
- (error "Odd number of keyword arguments: ~A." forms))
- (push
- (make-instance 'ps-js::js-object
- :slots
- (loop for (name val) on expressions-subl by #'cddr
- collect (list name val)))
- effective-expressions)
- (setf expressions-subl nil))
- (progn
- (push arg-expr effective-expressions)
- (setf expressions-subl (rest expressions-subl)))))))))
-
-(defmethod compile-parenscript-form ((comp-env compilation-environment) (form cons))
+ (when (and (listp arg) (eql (first arg) 'script-quote)) (second arg))))
+ (let ((compiled-args (mapcar #'compile-parenscript-form arg-forms)))
+ (do ((effective-expressions nil)
+ (expressions-subl compiled-args))
+ ((not expressions-subl) (reverse effective-expressions))
+ (let ((arg-expr (first expressions-subl)))
+ (if (keyword-arg arg-expr)
+ (progn (when (oddp (length expressions-subl))
+ (error "Odd number of keyword arguments: ~A." arg-forms))
+ (push (list 'js-object (loop for (name val) on expressions-subl by #'cddr
+ collect (list name val)))
+ effective-expressions)
+ (setf expressions-subl nil))
+ (progn (push arg-expr effective-expressions)
+ (setf expressions-subl (rest expressions-subl)))))))))
+
+(defmethod compile-parenscript-form ((form cons) &key (expecting :statement))
(let* ((name (car form))
- (args (cdr form))
- (script-form (when (symbolp name) (get-script-special-form name))))
- (cond
- ((eql name 'quote) (make-instance 'script-quote :value (first args)))
- (script-form (apply script-form args))
- ((ps-js::op-form-p form)
- (make-instance 'ps-js::op-form
- :operator (ps-js::script-convert-op-name (compile-to-symbol (first form)))
- :args (mapcar #'compile-to-expression (rest form))))
- ((method-call-p form)
- (make-instance 'ps-js::method-call
- :method (compile-to-symbol name)
- :object (compile-to-expression (first args))
- :args (compile-function-argument-forms (rest args))))
- ((funcall-form-p form)
- (make-instance 'ps-js::function-call
- :function (compile-to-expression name)
- :args (compile-function-argument-forms args)))
- (t (error "Unknown form ~S" form)))))
-
-(defun compile-script-form (form &key (comp-env *compilation-environment*))
- "Compiles a Parenscript form to an AST node."
- (compile-parenscript-form comp-env form))
-
-(defun compile-to-expression (form)
- "Compiles the given Parenscript form and guarantees the result is an expression."
- (let ((res (compile-script-form form)))
- (assert (typep res 'ps-js::expression) ()
- "Error: ~s was expected to compile to a ParenScript expression, but instead compiled to ~s, which has type ~s"
- form res (type-of res))
- res))
+ (args (cdr form)))
+ (cond ((eql name 'quote)
+ (assert (= 1 (length args)) () "Wrong number of arguments to quote: ~s" args)
+ (list 'script-quote (first args)))
+ ((ps-special-form-p form) (apply (get-ps-special-form name) (cons expecting args)))
+ ((op-form-p form)
+ (list 'operator
+ (script-convert-op-name (compile-parenscript-form (first form) :expecting :symbol))
+ (mapcar (lambda (form) (compile-parenscript-form form :expecting :expression)) (rest form))))
+ ((method-call-p form)
+ (list 'js-method-call
+ (compile-parenscript-form name :expecting :symbol)
+ (compile-parenscript-form (first args) :expecting :expression)
+ (compile-function-argument-forms (rest args))))
+ ((funcall-form-p form)
+ (list 'js-funcall
+ (compile-parenscript-form name :expecting :expression)
+ (compile-function-argument-forms args)))
+ (t (error "Cannot compile ~S to a ParenScript form." form)))))
-(defun compile-to-symbol (form)
- "Compiles the given Parenscript form and guarantees a symbolic result. This
-also guarantees that the symbol has an associated script-package."
- (let ((res (compile-script-form form)))
- (when (typep res 'ps-js::js-variable)
- (setf res (ps-js::value res)))
- (when (typep res 'ps-js::script-quote)
- (setf res (ps-js::value res)))
- (assert (symbolp res) ()
- "~a is expected to be a symbol, but compiles to ~a (the ParenScript output for ~a alone is \"~a\"). This could be due to ~a being a special form." form res form (ps::ps* form) form)
- (unless (symbol-script-package res)
- (when *warn-ps-package*
- (warn 'simple-style-warning
- :format-control "The symbol ~A::~A has no associated script package."
- :format-arguments (list (if (symbol-package res) (package-name (symbol-package res)) "ANONYMOUS-PACKAGE")
- res))))
- res))
-
-(defun compile-to-statement (form)
- "Compiles the given Parenscript form and guarantees the result is a statement."
- (let ((res (compile-script-form form)))
- (assert (typep res 'ps-js::statement))
- res))
-
-(defun compile-to-block (form &key (indent ""))
- "Compiles the given Parenscript form and guarantees the result is of type SCRIPT-BODY"
- (let ((res (compile-to-statement form)))
- (if (typep res 'ps-js::js-block)
- (progn (setf (ps-js::block-indent res) indent)
- res)
- (make-instance 'ps-js::js-block
- :indent indent
- :statements (list res)))))
\ No newline at end of file
;;;; The macrology of the Parenscript language. Special forms and macros.
;;; parenscript gensyms
-(defvar *gen-script-name-counter* 0)
+(defvar *ps-gensym-counter* 0)
-(defun gen-script-name-string (&key (prefix "_js_"))
- "Generates a unique valid javascript identifier ()"
- (concatenate 'string
- prefix (princ-to-string (incf *gen-script-name-counter*))))
+(defun ps-gensym (&optional (prefix "_js"))
+ (make-symbol (format nil "~A-~A" prefix (incf *ps-gensym-counter*))))
-(defun gen-script-name (&key (prefix "_ps_"))
- "Generate a new javascript identifier."
- (intern (gen-script-name-string :prefix prefix)
- (find-package :parenscript.ps-gensyms)))
-
-(defmacro gen-ps-name (&rest args)
- `(gen-script-name ,@args))
-
-(defmacro with-unique-ps-names (symbols &body body)
- "Evaluate BODY with the variables on SYMBOLS bound to new javascript identifiers.
+(defmacro with-ps-gensyms (symbols &body body)
+ "Evaluate BODY with SYMBOLS bound to unique ParenScript identifiers.
Each element of SYMBOLS is either a symbol or a list of (symbol
-prefix)."
+gensym-prefix-string)."
`(let* ,(mapcar (lambda (symbol)
(destructuring-bind (symbol &optional prefix)
(if (consp symbol)
symbol
(list symbol))
(if prefix
- `(,symbol (gen-script-name :prefix ,prefix))
- `(,symbol (gen-script-name)))))
+ `(,symbol (ps-gensym ,prefix))
+ `(,symbol (ps-gensym)))))
symbols)
,@body))
-(defvar *var-counter* 0)
-
-(defun script-gensym (&optional (name "js"))
- (intern (format nil "tmp-~A-~A" name (incf *var-counter*)) #.*package*))
-
-(defscriptmacro defaultf (place value)
+(defpsmacro defaultf (place value)
`(setf ,place (or (and (=== undefined ,place) ,value)
,place)))
;;; array literals
-(defscriptmacro list (&rest values)
+(defpsmacro list (&rest values)
`(array ,@values))
-(defscriptmacro make-array (&rest inits)
+(defpsmacro make-array (&rest inits)
`(new (*array ,@inits)))
-;;; eval-when
-(define-script-special-form eval-when (&rest args)
- "(eval-when form-language? (situation*) form*)
-
-The given forms are evaluated only during the given SITUATION in the specified
-FORM-LANGUAGE (either :lisp or :parenscript, def, defaulting to :lisp during
--toplevel and :parenscript during :execute). The accepted SITUATIONS are :execute,
-:scan-toplevel. :scan-toplevel is the phase of compilation when function definitions
-and the like are being added to the compilation environment. :execute is the phase when
-the code is being evaluated by a Javascript engine."
- (multiple-value-bind (body-language situations subforms)
- (process-eval-when-args args)
- (cond
- ((and (compiler-in-situation-p *compilation-environment* :compile-toplevel)
- (find :compile-toplevel situations))
- (error "Should never be processing eval-when :COMPILE-TOPLEVEL forms from here."))
-
- ((and (compiler-in-situation-p *compilation-environment* :execute)
- (find :execute situations))
- (when (eql body-language :parenscript)
- (let ((form `(progn ,@subforms)))
- (compile-to-statement form)))))))
-
;;; slot access
-(defscriptmacro slot-value (obj &rest slots)
+(defpsmacro slot-value (obj &rest slots)
(if (null (rest slots))
`(%js-slot-value ,obj ,(first slots))
`(slot-value (slot-value ,obj ,(first slots)) ,@(rest slots))))
-(defscriptmacro with-slots (slots object &rest body)
+(defpsmacro with-slots (slots object &rest body)
(flet ((slot-var (slot) (if (listp slot) (first slot) slot))
(slot-symbol (slot) (if (listp slot) (second slot) slot)))
`(symbol-macrolet ,(mapcar #'(lambda (slot)
slots)
,@body)))
-;;; script packages
-(defscriptmacro defpackage (name &rest options)
- "Defines a Parenscript package."
- (labels ((opt-name (opt) (if (listp opt) (car opt) opt)))
- (let ((nicknames nil) (lisp-package nil) (secondary-lisp-packages nil)
- (exports nil) (used-packages nil) (documentation nil))
- (dolist (opt options)
- (case (opt-name opt)
- (:lisp-package (setf lisp-package (second opt)))
- (:nicknames (setf nicknames (rest opt)))
- (:secondary-lisp-packages secondary-lisp-packages t)
- (:export (setf exports (rest opt)))
- (:use (setf used-packages (rest opt)))
- (:documentation (setf documentation (second opt)))
- (t (error "Unknown option in DEFPACKAGE: ~A" (opt-name opt)))))
- (create-script-package
- *compilation-environment*
- :name name
- :nicknames nicknames
- :secondary-lisp-packages secondary-lisp-packages
- :used-packages used-packages
- :lisp-package lisp-package
- :exports exports
- :documentation documentation)))
- `(progn))
-
-(defscriptmacro in-package (package-designator)
- "Changes the current script package in the parenscript compilation environment. This mostly
-affects the reader and how it interns non-prefixed symbols"
- (let ((script-package
- (find-script-package package-designator *compilation-environment*)))
- (when (null script-package)
- (error "~A does not designate any script package. Available script package: ~A"
- package-designator
- (mapcar #'script-package-name (comp-env-script-packages *compilation-environment*))))
- (setf (comp-env-current-package *compilation-environment*)
- script-package)
- `(progn)))
-
-(defscriptmacro case (value &rest clauses)
+(defpsmacro case (value &rest clauses)
(labels ((make-clause (val body more)
(cond ((listp val)
(append (mapcar #'list (butlast val))
(make-clause 'default body more))
(more `((,val ,@body break)))
(t `((,val ,@body))))))
- `(switch ,value ,@(mapcon #'(lambda (x)
- (make-clause (car (first x))
- (cdr (first x))
- (rest x)))
+ `(switch ,value ,@(mapcon (lambda (clause)
+ (make-clause (car (first clause))
+ (cdr (first clause))
+ (rest clause)))
clauses))))
-;;; let
-(define-script-special-form let (decls &rest body)
- (let ((defvars (mapcar #'(lambda (decl)
- (if (atom decl)
- (make-instance 'ps-js::js-defvar
- :names (list (compile-to-symbol decl))
- :value nil)
- (let ((name (first decl))
- (value (second decl)))
- (make-instance 'ps-js::js-defvar
- :names (list (compile-to-symbol name))
- :value (compile-to-expression value)))))
- decls)))
- (make-instance 'ps-js::js-sub-block
- :indent " "
- :statements (nconc defvars
- (mapcar #'compile-to-statement body)))))
+(define-ps-special-form let (expecting bindings &rest body)
+ (let ((defvars (mapcar (lambda (binding) (if (atom binding)
+ `(defvar ,binding)
+ `(defvar ,@binding)))
+ bindings)))
+ (compile-parenscript-form `(progn ,@defvars ,@body))))
;;; iteration
-(defscriptmacro dotimes (iter &rest body)
+(defpsmacro dotimes (iter &rest body)
(let ((var (first iter))
(times (second iter)))
`(do ((,var 0 (1+ ,var)))
((>= ,var ,times))
,@body)))
-(defscriptmacro dolist (i-array &rest body)
+(defpsmacro dolist (i-array &rest body)
(let ((var (first i-array))
(array (second i-array))
- (arrvar (script-gensym "arr"))
- (idx (script-gensym "i")))
+ (arrvar (ps-gensym "tmp-arr"))
+ (idx (ps-gensym "tmp-i")))
`(let ((,arrvar ,array))
(do ((,idx 0 (1+ ,idx)))
- ((>= ,idx (slot-value ,arrvar 'global::length)))
+ ((>= ,idx (slot-value ,arrvar 'length)))
(let ((,var (aref ,arrvar ,idx)))
,@body)))))
(*script-macro-env* (cons ,var *script-macro-env*)))
,@body))
-(define-script-special-form macrolet (macros &body body)
+(define-ps-special-form macrolet (expecting macros &body body)
(with-temp-macro-environment (macro-env-dict)
(dolist (macro macros)
(destructuring-bind (name arglist &body body)
(destructuring-bind ,arglist
,args
,@body))))))))
- (compile-script-form `(progn ,@body))))
+ (compile-parenscript-form `(progn ,@body))))
-(define-script-special-form symbol-macrolet (symbol-macros &body body)
+(define-ps-special-form symbol-macrolet (expecting symbol-macros &body body)
(with-temp-macro-environment (macro-env-dict)
(dolist (macro symbol-macros)
(destructuring-bind (name &body expansion)
macro
(setf (get-macro-spec name macro-env-dict)
(cons t (compile nil `(lambda () ,@expansion))))))
- (compile-script-form `(progn ,@body))))
+ (compile-parenscript-form `(progn ,@body))))
-(define-script-special-form defmacro (name args &body body)
+(define-ps-special-form defmacro (expecting name args &body body)
(define-script-macro% name args body :symbol-macro-p nil)
- (compile-script-form '(progn)))
+ nil)
-(define-script-special-form define-symbol-macro (name &body body)
+(define-ps-special-form define-symbol-macro (expecting name &body body)
(define-script-macro% name () body :symbol-macro-p t)
- (compile-script-form '(progn)))
+ nil)
-(defscriptmacro lisp (&body forms)
+(defpsmacro lisp (&body forms)
"Evaluates the given forms in Common Lisp at ParenScript
macro-expansion time. The value of the last form is treated as a
ParenScript expression and is inserted into the generated Javascript
\(use nil for no-op)."
(eval (cons 'progn forms)))
-(defscriptmacro rebind (variables &body body)
+(defpsmacro rebind (variables &body body)
"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
effective-body)))
(values effective-args effective-body)))))
-(ps:defscriptmacro defun (name lambda-list &body body)
+(defpsmacro defun (name lambda-list &body body)
"An extended defun macro that allows cool things like keyword arguments.
lambda-list::=
(var*
"(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list)
`(defun-setf ,name ,lambda-list ,@body))))
-(ps:defscriptmacro defun-normal (name lambda-list &body body)
+(defpsmacro defun-normal (name lambda-list &body body)
(multiple-value-bind (effective-args effective-body)
(parse-extended-function lambda-list body name)
`(%js-defun ,name ,effective-args
(defvar *defun-setf-name-prefix* "__setf_")
-(ps:defscriptmacro defun-setf (setf-name lambda-list &body body)
+(defpsmacro defun-setf (setf-name lambda-list &body body)
(let ((mangled-function-name (intern (concatenate 'string *defun-setf-name-prefix* (symbol-name (second setf-name)))
(symbol-package (second setf-name))))
(function-args (cdr (ordered-set-difference lambda-list lambda-list-keywords))))
`(,',mangled-function-name ,store-var ,@(list ,@function-args)))
(defun ,mangled-function-name ,lambda-list ,@body))))
-(ps:defscriptmacro lambda (lambda-list &body body)
+(defpsmacro lambda (lambda-list &body body)
"An extended defun macro that allows cool things like keyword arguments.
lambda-list::=
(var*
`(%js-lambda ,effective-args
,@effective-body)))
-(ps:defscriptmacro defsetf-long (access-fn lambda-list (store-var) form)
+(defpsmacro defsetf-long (access-fn lambda-list (store-var) form)
(setf (get-macro-spec access-fn *script-setf-expanders*)
(compile nil
(let ((var-bindings (ordered-set-difference lambda-list lambda-list-keywords)))
`(lambda (access-fn-args store-form)
(destructuring-bind ,lambda-list
access-fn-args
- (let* ((,store-var (ps:gen-ps-name))
- (gensymed-names (loop repeat ,(length var-bindings) collecting (ps:gen-ps-name)))
+ (let* ((,store-var (ps-gensym))
+ (gensymed-names (loop repeat ,(length var-bindings) collecting (ps-gensym)))
(gensymed-arg-bindings (mapcar #'list gensymed-names (list ,@var-bindings))))
(destructuring-bind ,var-bindings
gensymed-names
,,form))))))))
nil)
-(ps:defscriptmacro defsetf-short (access-fn update-fn &optional docstring)
+(defpsmacro defsetf-short (access-fn update-fn &optional docstring)
(declare (ignore docstring))
(setf (get-macro-spec access-fn *script-setf-expanders*)
(lambda (access-fn-args store-form)
(flet ((process-setf-clause (place value-form)
(if (and (listp place) (get-macro-spec (car place) *script-setf-expanders*))
(funcall (get-macro-spec (car place) *script-setf-expanders*) (cdr place) value-form)
- (let ((exp-place (expand-script-form place)))
+ (let ((exp-place (ps-macroexpand place)))
(if (and (listp exp-place) (get-macro-spec (car exp-place) *script-setf-expanders*))
(funcall (get-macro-spec (car exp-place) *script-setf-expanders*) (cdr exp-place) value-form)
- `(parenscript.javascript::setf1% ,exp-place ,value-form))))))
+ `(setf1% ,exp-place ,value-form))))))
(assert (evenp (length args)) ()
"~s does not have an even number of arguments." (cons 'setf args))
`(progn ,@(loop for (place value) on args by #'cddr collect (process-setf-clause place value)))))
+++ /dev/null
-(in-package :parenscript)
-
-;;; quote
-(defscriptclass script-quote (ps-js::expression)
- ())
-
-;;; Compilation environment stuff
-
-(defvar *compilation-environment* nil
- "The active compilation environment."
-;; Right now all code assumes that *compilation-environment* is accurately bound to the
-;; current compilation environment--even some functions that take the compilation environment
-;; as arguments.
- )
-
-;; environmental considerations
-(defgeneric setup-compilation-environment (comp-env)
- (:documentation "Sets up a basic compilation environment prepared for a language user.
-This should do things like define packages and set the current package.
-
-Returns the compilation-environment."))
-
-(defun make-basic-compilation-environment ()
- "Creates a compilation environment object from scratch. Fills it in with the default
-script packages (parenscript, global, and parenscript-user)."
- (let ((*compilation-environment* (make-instance 'compilation-environment)))
- (setup-compilation-environment *compilation-environment*)))
\ No newline at end of file
HCoop / clinton / parenscript.git / commitdiff