-(in-package :parenscript)
-
-;;; special forms
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defvar *js-special-forms* (make-hash-table :test 'equal)
- "A hash-table containing functions that implement ParenScript
-special forms, indexed by name (a string).")
-
- (defun undefine-js-special-form (name)
- (when (gethash (symbol-name name) *js-special-forms*)
- (warn "Redefining ParenScript special form ~S" name)
- (remhash (symbol-name name) *js-special-forms*))))
-
-(defmacro define-js-special-form (name lambda-list &rest body)
- "Define a special form NAME. Arguments are destructured according to
-LAMBDA-LIST. The resulting JS language types are appended to the
-ongoing javascript compilation."
- (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*))
- (arglist (gensym "ps-arglist-")))
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun ,js-name (&rest ,arglist)
- (destructuring-bind ,lambda-list
- ,arglist
- ,@body))
- (setf (gethash ,(symbol-name name) *js-special-forms*) #',js-name))))
-
-(defun js-special-form-p (form)
- (and (consp form)
- (symbolp (car form))
- (gethash (symbol-name (car form)) *js-special-forms*)))
-
-(defun js-get-special-form (name)
- (when (symbolp name)
- (gethash (symbol-name name) *js-special-forms*)))
-
-;;; macro expansion
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun make-macro-env-dictionary ()
- (make-hash-table :test 'equal))
-
- (defvar *js-macro-toplevel* (make-macro-env-dictionary)
- "Toplevel macro environment dictionary. Key is symbol-name of the macro, value is (symbol-macro-p . expansion-function).")
- (defvar *js-macro-env* (list *js-macro-toplevel*)
- "Current macro environment."))
-
-(defmacro get-macro-spec (name env-dict)
- `(gethash (symbol-name ,name) ,env-dict))
-
-(defun lookup-macro-spec (name &optional (environment *js-macro-env*))
- (when (symbolp name)
- (do ((env environment (cdr env)))
- ((null env) nil)
- (let ((val (get-macro-spec name (car env))))
- (when val
- (return-from lookup-macro-spec
- (values val (or (cdr env)
- (list *js-macro-toplevel*)))))))))
-
-(defun symbol-macro-p (name &optional (environment *js-macro-env*))
- (and (symbolp name) (car (lookup-macro-spec name environment))))
-
-(defun macro-p (name &optional (environment *js-macro-env*))
- (and (symbolp name) (let ((macro-spec (lookup-macro-spec name environment)))
- (and macro-spec (not (car macro-spec))))))
-
-(defun lookup-macro-expansion-function (name &optional (environment *js-macro-env*))
- "Lookup NAME in the given macro expansion environment (which
-defaults to the current macro environment). Returns the expansion
-function and the parent macro environment of the macro."
- (multiple-value-bind (macro-spec parent-env)
- (lookup-macro-spec name environment)
- (values (cdr macro-spec) parent-env)))
-
-(defmacro defjsmacro (name args &rest body)
- "Define a ParenScript macro, and store it in the toplevel ParenScript macro environment."
- (let ((lambda-list (gensym "ps-lambda-list-"))
- (body (if (stringp (first body)) (rest body) body))) ;; drop docstring
- (undefine-js-special-form name)
- `(setf (get-macro-spec ',name *js-macro-toplevel*)
- (cons nil (lambda (&rest ,lambda-list)
- (destructuring-bind ,args
- ,lambda-list
- ,@body))))))
-
-(defmacro defmacro/js (name args &body body)
- "Define a Lisp macro and import it into the ParenScript macro environment."
- `(progn (defmacro ,name ,args ,@body)
- (js:import-macros-from-lisp ',name)))
-
-(defmacro defmacro+js (name args &body body)
- "Define a Lisp macro and a ParenScript macro in their respective
-macro environments. This function should be used when you want to use
-the same macro in both Lisp and ParenScript, but the 'macroexpand' of
-that macro in Lisp makes the Lisp macro unsuitable to be imported into
-the ParenScript macro environment."
- `(progn (defmacro ,name ,args ,@body)
- (js:defjsmacro ,name ,args ,@body)))
-
-(defun import-macros-from-lisp (&rest names)
- "Import the named Lisp macros into the ParenScript macro environment."
- (dolist (name names)
- (let ((name name))
- (undefine-js-special-form name)
- (setf (get-macro-spec name *js-macro-toplevel*)
- (cons nil (lambda (&rest args)
- (macroexpand `(,name ,@args))))))))
-
-(defun js-expand-form (expr)
- (if (consp expr)
- (let ((op (car expr))
- (args (cdr expr)))
- (cond ((equal op 'quote) expr)
- ((macro-p op) (multiple-value-bind (expansion-function macro-env)
- (lookup-macro-expansion-function op)
- (js-expand-form (let ((*js-macro-env* macro-env))
- (apply expansion-function args)))))
- (t expr)))
- (cond ((js-special-form-p expr) expr)
- ((symbol-macro-p expr) (multiple-value-bind (expansion-function macro-env)
- (lookup-macro-expansion-function expr)
- (js-expand-form (let ((*js-macro-env* macro-env))
- (funcall expansion-function)))))
- (t expr))))
-
-(defvar *gen-js-name-counter* 0)
-
-(defun gen-js-name-string (&key (prefix "_ps_"))
- "Generates a unique valid javascript identifier ()"
- (concatenate 'string
- prefix (princ-to-string (incf *gen-js-name-counter*))))
-
-(defun gen-js-name (&key (prefix "_ps_"))
- "Generate a new javascript identifier."
- (intern (gen-js-name-string :prefix prefix)
- (find-package :js)))
-
-(defmacro with-unique-js-names (symbols &body body)
- "Evaluate BODY with the variables on SYMBOLS bound to new javascript identifiers.
-
-Each element of SYMBOLS is either a symbol or a list of (symbol
-prefix)."
- `(let* ,(mapcar (lambda (symbol)
- (destructuring-bind (symbol &optional prefix)
- (if (consp symbol)
- symbol
- (list symbol))
- (if prefix
- `(,symbol (gen-js-name :prefix ,prefix))
- `(,symbol (gen-js-name)))))
- symbols)
- ,@body))
-
-(defjsmacro rebind (variables expression)
- "Creates a new js lexical environment and copies the given
- variable(s) there. Executes the body in the new environment. This
- has the same effect as a new (let () ...) form in lisp but works on
- the js side for js closures."
- (unless (listp variables)
- (setf variables (list variables)))
- `((lambda ()
- (let ((new-context (new *object)))
- ,@(loop for variable in variables
- do (setf variable (symbol-to-js variable))
- collect `(setf (slot-value new-context ,variable) (slot-value this ,variable)))
- (with new-context
- (return ,expression))))))
-
-(defvar *var-counter* 0)
-
-(defun js-gensym (&optional (name "js"))
- (intern (format nil "tmp-~A-~A" name (incf *var-counter*)) #.*package*))
-
-;;; reserved Javascript keywords
-
-(defvar *reserved-javascript-keywords*
- '("abstract" "else" "instanceof" "switch" "boolean" "enum" "int" "synchronized"
- "break" "export" "interface" "this" "byte" "extends" "long" "throw" "case"
- "native" "throws" "catch" "final" "new" "transient" "char" "finally" "float"
- "package" "try" "const" "for" "private" "typeof" "continue" "function"
- "protected" "var" "debugger" "goto" "public" "void" "default" "if" "return"
- "volatile" "delete" "implements" "short" "while" "do" "import" "static" "with"
- "double" "in" "super" "class"))
-
-(defun reserved-identifier-p (id-string)
- (find id-string *reserved-javascript-keywords* :test #'string-equal))
-
-(defmethod initialize-instance :after ((var js-variable) &rest initargs)
- (declare (ignore initargs))
- (when (reserved-identifier-p (slot-value var 'value))
- (warn "~a is a reserved Javascript keyword and should not be used as a variable or function name." (slot-value var 'value))))
-
-;;; literals
-
-(defmacro defjsliteral (name string)
- "Define a Javascript literal that will expand to STRING."
- `(define-js-special-form ,name () (make-instance 'expression :value ,string)))
-
-(defjsliteral this "this")
-(defjsliteral t "true")
-(defjsliteral nil "null")
-(defjsliteral false "false")
-(defjsliteral undefined "undefined")
-
-(defmacro defjskeyword (name string)
- "Define a Javascript keyword that will expand to STRING."
- `(define-js-special-form ,name () (make-instance 'statement :value ,string)))
-
-(defjskeyword break "break")
-(defjskeyword continue "continue")
-
-;;; array literals
-
-(define-js-special-form array (&rest values)
- (make-instance 'array-literal
- :values (mapcar #'js-compile-to-expression values)))
-
-(defjsmacro list (&rest values)
- `(array ,@values))
-
-(define-js-special-form aref (array &rest coords)
- (make-instance 'js-aref
- :array (js-compile-to-expression array)
- :index (mapcar #'js-compile-to-expression coords)))
-
-
-(defjsmacro make-array (&rest inits)
- `(new (*array ,@inits)))
-
-;;; object literals (maps and hash-tables)
-
-(define-js-special-form {} (&rest values)
- (make-instance 'object-literal
- :values (loop
- for (key value) on values by #'cddr
- collect (cons key (js-compile-to-expression value)))))
-
-;;; operators
-(define-js-special-form ++ (x)
- (make-instance 'one-op :pre-p nil :op "++"
- :value (js-compile-to-expression x)))
-
-(define-js-special-form -- (x)
- (make-instance 'one-op :pre-p nil :op "--"
- :value (js-compile-to-expression x)))
-
-(define-js-special-form incf (x &optional (delta 1))
- (if (eql delta 1)
- (make-instance 'one-op :pre-p t :op "++"
- :value (js-compile-to-expression x))
- (make-instance 'op-form
- :operator '+=
- :args (mapcar #'js-compile-to-expression
- (list x delta )))))
-
-(define-js-special-form decf (x &optional (delta 1))
- (if (eql delta 1)
- (make-instance 'one-op :pre-p t :op "--"
- :value (js-compile-to-expression x))
- (make-instance 'op-form
- :operator '-=
- :args (mapcar #'js-compile-to-expression
- (list x delta )))))
-
-(define-js-special-form - (first &rest rest)
- (if (null rest)
- (make-instance 'one-op
- :pre-p t
- :op "-"
- :value (js-compile-to-expression first))
- (make-instance 'op-form
- :operator '-
- :args (mapcar #'js-compile-to-expression
- (cons first rest)))))
-
-(define-js-special-form not (x)
- (let ((value (js-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-js-special-form ~ (x)
- (let ((expr (js-compile-to-expression x)))
- (make-instance 'one-op :pre-p t :op "~" :value expr)))
-
-;;; function calls
-
-(defun funcall-form-p (form)
- (and (listp form)
- (not (op-form-p form))
- (not (js-special-form-p form))))
-
-(defun method-call-p (form)
- (and (funcall-form-p form)
- (symbolp (first form))
- (eql (char (symbol-name (first form)) 0) #\.)))
-
-;;; progn
-
-(define-js-special-form progn (&rest body)
- (make-instance 'js-body
- :stmts (mapcar #'js-compile-to-statement body)))
-
-(defmethod expression-precedence ((body js-body))
- (if (= (length (b-stmts body)) 1)
- (expression-precedence (first (b-stmts body)))
- (op-precedence 'comma)))
-
-;;; function definition
-(define-js-special-form lambda (args &rest body)
- (make-instance 'js-lambda
- :args (mapcar #'js-compile-to-symbol args)
- :body (make-instance 'js-body
- :indent " "
- :stmts (mapcar #'js-compile-to-statement body))))
-
-(define-js-special-form defun (name args &rest body)
- (make-instance 'js-defun
- :name (js-compile-to-symbol name)
- :args (mapcar #'js-compile-to-symbol args)
- :body (make-instance 'js-body
- :indent " "
- :stmts (mapcar #'js-compile-to-statement body))))
-
-;;; object creation
-(define-js-special-form create (&rest args)
- (make-instance 'js-object
- :slots (loop for (name val) on args by #'cddr
- collect (let ((name-expr (js-compile-to-expression name)))
- (assert (or (typep name-expr 'js-variable)
- (typep name-expr 'string-literal)
- (typep name-expr 'number-literal)))
- (list name-expr (js-compile-to-expression val))))))
-
-
-(define-js-special-form slot-value (obj slot)
- (make-instance 'js-slot-value :object (js-compile-to-expression obj)
- :slot (js-compile slot)))
-
-;;; cond
-(define-js-special-form cond (&rest clauses)
- (make-instance 'js-cond
- :tests (mapcar (lambda (clause) (js-compile-to-expression (car clause)))
- clauses)
- :bodies (mapcar (lambda (clause) (js-compile-to-body (cons 'progn (cdr clause)) :indent " "))
- clauses)))
-
-;;; if
-(define-js-special-form if (test then &optional else)
- (make-instance 'js-if :test (js-compile-to-expression test)
- :then (js-compile-to-body then :indent " ")
- :else (when else
- (js-compile-to-body else :indent " "))))
-
-(defmethod expression-precedence ((if js-if))
- (op-precedence 'if))
-
-;;; switch
-(define-js-special-form switch (value &rest clauses)
- (let ((clauses (mapcar #'(lambda (clause)
- (let ((val (first clause))
- (body (cdr clause)))
- (list (if (eql val 'default)
- 'default
- (js-compile-to-expression val))
- (js-compile-to-body (cons 'progn body) :indent " "))))
- clauses))
- (check (js-compile-to-expression value)))
- (make-instance 'js-switch :value check
- :clauses clauses)))
-
-
-(defjsmacro case (value &rest clauses)
- (labels ((make-clause (val body more)
- (cond ((listp val)
- (append (mapcar #'list (butlast val))
- (make-clause (first (last val)) body more)))
- ((member val '(t otherwise))
- (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)))
- 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 #'js-equal))
- (let ((args-without (remove lhs (op-args rhs)
- :count 1 :test #'js-equal))
- (args-without-first (remove lhs (op-args rhs)
- :count 1 :end 1
- :test #'js-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 (js-equal args-without one)
- (eql (operator rhs) '+))
- (make-instance 'one-op :pre-p nil :op "++"
- :value lhs))
- ((and (js-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)
- '(+ *))
- (js-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))
- (js-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-js-special-form setf (&rest args)
- (let ((assignments (loop for (lhs rhs) on args by #'cddr
- for rexpr = (js-compile-to-expression rhs)
- for lexpr = (js-compile-to-expression lhs)
- collect (make-js-test lexpr rexpr))))
- (if (= (length assignments) 1)
- (first assignments)
- (make-instance 'js-body :indent "" :stmts assignments))))
-
-(defmethod expression-precedence ((setf js-setf))
- (op-precedence '=))
-
-;;; defvar
-(define-js-special-form defvar (name &optional value)
- (make-instance 'js-defvar :names (list (js-compile-to-symbol name))
- :value (when value (js-compile-to-expression value))))
-
-;;; let
-(define-js-special-form let (decls &rest body)
- (let ((defvars (mapcar #'(lambda (decl)
- (if (atom decl)
- (make-instance 'js-defvar
- :names (list (js-compile-to-symbol decl))
- :value nil)
- (let ((name (first decl))
- (value (second decl)))
- (make-instance 'js-defvar
- :names (list (js-compile-to-symbol name))
- :value (js-compile-to-expression value)))))
- decls)))
- (make-instance 'js-sub-body
- :indent " "
- :stmts (nconc defvars
- (mapcar #'js-compile-to-statement body)))))
-
-;;; 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 (js-compile-to-symbol var))
- :value (js-compile-to-expression init))))
-
-(defun make-for-steps (decls)
- (loop for decl in decls
- when (= (length decl) 3)
- collect (js-compile-to-expression (third decl))))
-
-(define-js-special-form do (decls termination &rest body)
- (let ((vars (make-for-vars decls))
- (steps (make-for-steps decls))
- (check (js-compile-to-expression (list 'not (first termination))))
- (body (js-compile-to-body (cons 'progn body) :indent " ")))
- (make-instance 'js-for
- :vars vars
- :steps steps
- :check check
- :body body)))
-
-(defjsmacro dotimes (iter &rest body)
- (let ((var (first iter))
- (times (second iter)))
- `(do ((,var 0 (1+ ,var)))
- ((>= ,var ,times))
- ,@body)))
-
-(defjsmacro dolist (i-array &rest body)
- (let ((var (first i-array))
- (array (second i-array))
- (arrvar (js-gensym "arr"))
- (idx (js-gensym "i")))
- `(let ((,arrvar ,array))
- (do ((,idx 0 (1+ ,idx)))
- ((>= ,idx (slot-value ,arrvar 'length)))
- (let ((,var (aref ,arrvar ,idx)))
- ,@body)))))
-
-(define-js-special-form doeach (decl &rest body)
- (make-instance 'for-each :name (js-compile-to-symbol (first decl))
- :value (js-compile-to-expression (second decl))
- :body (js-compile-to-body (cons 'progn body) :indent " ")))
-
-(define-js-special-form while (check &rest body)
- (make-instance 'js-while
- :check (js-compile-to-expression check)
- :body (js-compile-to-body (cons 'progn body) :indent " ")))
-
-;;; with
-
-;;; try-catch
-(define-js-special-form try (body &rest clauses)
- (let ((body (js-compile-to-body 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 (js-compile-to-symbol (caar catch))
- (js-compile-to-body (cons 'progn (cdr catch))
- :indent " ")))
- :finally (when finally (js-compile-to-body (cons 'progn finally)
- :indent " ")))))
-;;; regex
-(define-js-special-form regex (regex)
- (make-instance 'regex :value (string regex)))
-
-;;; TODO instanceof
-(define-js-special-form instanceof (value type)
- (make-instance 'js-instanceof
- :value (js-compile-to-expression value)
- :type (js-compile-to-expression type)))
-
-;;; single operations
-(defmacro define-parse-js-single-op (name &optional (superclass 'expression))
- (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*)))
- `(define-js-special-form ,name (value)
- (make-instance ',js-name :value (js-compile-to-expression value)))
- ))
-
-(define-parse-js-single-op return statement)
-(define-parse-js-single-op throw statement)
-(define-parse-js-single-op delete)
-(define-parse-js-single-op void)
-(define-parse-js-single-op typeof)
-(define-parse-js-single-op new)
-
-;;; conditional compilation
-(define-js-special-form cc-if (test &rest body)
- (make-instance 'cc-if :test test
- :body (mapcar #'js-compile body)))
-
-;;; standard macros
-(defjsmacro with-slots (slots object &rest body)
- `(symbol-macrolet ,(mapcar #'(lambda (slot)
- `(,slot '(slot-value ,object ',slot)))
- slots)
- ,@body))
-
-(defjsmacro when (test &rest body)
- `(if ,test (progn ,@body)))
-
-(defjsmacro unless (test &rest body)
- `(if (not ,test) (progn ,@body)))
-
-(defjsmacro 1- (form)
- `(- ,form 1))
-
-(defjsmacro 1+ (form)
- `(+ ,form 1))
-
-;;; macros
-(defmacro with-temp-macro-environment ((var) &body body)
- `(let* ((,var (make-macro-env-dictionary))
- (*js-macro-env* (cons ,var *js-macro-env*)))
- ,@body))
-
-(define-js-special-form macrolet (macros &body body)
- (with-temp-macro-environment (macro-env-dict)
- (dolist (macro macros)
- (destructuring-bind (name arglist &body body)
- macro
- (setf (get-macro-spec name macro-env-dict)
- (cons nil (let ((args (gensym "ps-macrolet-args-")))
- (compile nil `(lambda (&rest ,args)
- (destructuring-bind ,arglist
- ,args
- ,@body))))))))
- (js-compile `(progn ,@body))))
-
-(define-js-special-form symbol-macrolet (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))))))
- (js-compile `(progn ,@body))))
-
-(defjsmacro defmacro (name args &body body)
- `(lisp (defjsmacro ,name ,args ,@body) nil))
-
-(defjsmacro 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)))
-
-;;; Math library
-(defjsmacro floor (expr)
- `(*Math.floor ,expr))
-
-(defjsmacro random ()
- `(*Math.random))
-
-(defjsmacro evenp (num)
- `(= (% ,num 2) 0))
-
-(defjsmacro oddp (num)
- `(= (% ,num 2) 1))
-
-;;; helper macros
-(define-js-special-form js (&rest body)
- (make-instance 'string-literal
- :value (string-join (js-to-statement-strings
- (js-compile (cons 'progn body)) 0) " ")))
-
-(define-js-special-form js-inline (&rest body)
- (make-instance 'string-literal
- :value (concatenate
- 'string
- "javascript:"
- (string-join (js-to-statement-strings
- (js-compile (cons 'progn body)) 0) " "))))
-
-;;;; compiler interface ;;;;
-(defun js-compile (form)
- (setf form (js-expand-form form))
- (cond ((stringp form)
- (make-instance 'string-literal :value form))
- ((characterp form)
- (make-instance 'string-literal :value (string form)))
- ((numberp form)
- (make-instance 'number-literal :value form))
- ((symbolp form)
- (let ((c-macro (js-get-special-form form)))
- (if c-macro
- (funcall c-macro)
- (make-instance 'js-variable :value form))))
- ((and (consp form)
- (eql (first form) 'quote))
- (make-instance 'js-quote :value (second form)))
- ((consp form)
- (js-compile-list form))
- (t (error "Unknown atomar expression ~S" form))))
-
-(defun js-compile-list (form)
- (let* ((name (car form))
- (args (cdr form))
- (js-form (js-get-special-form name)))
- (cond (js-form
- (apply js-form args))
-
- ((op-form-p form)
- (make-instance 'op-form
- :operator (js-convert-op-name (js-compile-to-symbol (first form)))
- :args (mapcar #'js-compile-to-expression (rest form))))
-
- ((method-call-p form)
- (make-instance 'method-call
- :method (js-compile-to-symbol (first form))
- :object (js-compile-to-expression (second form))
- :args (mapcar #'js-compile-to-expression (cddr form))))
-
- ((funcall-form-p form)
- (make-instance 'function-call
- :function (js-compile-to-expression (first form))
- :args (mapcar #'js-compile-to-expression (rest form))))
-
- (t (error "Unknown form ~S" form)))))
-
-(defun js-compile-to-expression (form)
- (let ((res (js-compile form)))
- (assert (typep res 'expression))
- res))
-
-(defun js-compile-to-symbol (form)
- (let ((res (js-compile form)))
- (when (typep res 'js-variable)
- (setf res (value res)))
- (assert (symbolp res) ()
- "~a is expected to be a symbol, but compiles to ~a. This could be due to ~a being a special form." form res form)
- res))
-
-(defun js-compile-to-statement (form)
- (let ((res (js-compile form)))
- (assert (typep res 'statement))
- res))
-
-(defun js-compile-to-body (form &key (indent ""))
- (let ((res (js-compile-to-statement form)))
- (if (typep res 'js-body)
- (progn (setf (b-indent res) indent)
- res)
- (make-instance 'js-body
- :indent indent
- :stmts (list res)))))
-
-(defmacro js (&rest body)
- `(js* '(progn ,@body)))
-
-(defmacro js* (&rest body)
- "Return the javascript string representing BODY.
-
-Body is evaluated."
- `(string-join
- (js-to-statement-strings (js-compile (list 'progn ,@body)) 0)
- (string #\Newline)))
-
-(defun js-to-string (expr)
- (string-join
- (js-to-statement-strings (js-compile expr) 0)
- (string #\Newline)))
-
-(defun js-to-line (expr)
- (string-join
- (js-to-statement-strings (js-compile expr) 0) " "))
-
-(defmacro js-file (&rest body)
- `(html
- (:princ
- (js ,@body))))
-
-(defmacro js-script (&rest body)
- `((:script :type "text/javascript")
- (:princ (format nil "~%// <![CDATA[~%"))
- (:princ (js ,@body))
- (:princ (format nil "~%// ]]>~%"))))
-
-(defmacro js-inline (&rest body)
- `(js-inline* '(progn ,@body)))
-
-(defmacro js-inline* (&rest body)
- "Just like JS-INLINE except that BODY is evaluated before being
-converted to javascript."
- `(concatenate 'string "javascript:"
- (string-join (js-to-statement-strings (js-compile (list 'progn ,@body)) 0) " ")))
-
-
+(in-package :parenscript)
+
+;;;; The mechanisms for defining macros & parsing Parenscript.
+
+(defclass identifier ()
+ ((symbol :accessor id-symbol :initform nil :type symbol))
+ (:documentation ""))
+
+(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).")
+ (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 :initform nil :initarg :exports
+ :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
+ (exclusive-lisp-package-p
+ :initform nil :initarg :exclusive-lisp-package?
+ :accessor script-package-exclusive-lisp-package-p
+ :documentation "t if the lisp package is an anonymous package created exclusively for
+ the script package.")
+; (toplevel-identifiers :accessor script-package-toplevel-ids :initarg :toplevel-ids
+; :initform nil)
+; (macro-table :accessor script-package-macro-table
+; :initform (make-hash-table :test #'eql)
+; :documentation "This package's macro environment, set up as a hash table
+; from symbols to macro functions")
+; (special-form-table :accessor script-package-special-form-table
+; :initform (make-hash-table :test #'equal)
+; :documentation "Holds special form macros for the package.
+; Probably not used except for built-in packages."))
+ )
+ (:documentation "A Parenscript package is a lisp object that holds information
+about a set of Suavescript code."))
+
+(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."))
+ (:documentation ""))
+
+(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.")
+ (: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)
+ ))
+
+(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.")
+
+;;; parenscript packages
+(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))
+
+(defun symbol-script-package (symbol &optional (comp-env *compilation-environment*))
+ "Gets the Parenscript package associated with a Lisp symbol."
+ (lisp-to-script-package (symbol-package symbol) comp-env))
+
+(defun find-script-package (name &optional (comp-env *compilation-environment*))
+ "Find the script package with the name NAME in the given compilation environment."
+ (find (string name) (comp-env-script-packages comp-env) :test #'equal))
+
+(defun destroy-script-package (script-package)
+ "Disposes of relevant resources when the script package is no longer relevant."
+ (when (script-package-exclusive-lisp-package-p script-package)
+ (delete-package (script-package-lisp-package script-package))))
+
+;; environmental considerations
+(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 ((comp-env (make-instance 'compilation-environment)))
+ comp-env))
+
+(defun create-script-package (comp-env
+ &key name nicknames secondary-lisp-packages used-packages
+ lisp-package exports documentation)
+ "Creates a script package in the given compilation environment"
+ (labels ((normalize (string-like) (string string-like)))
+ (let* ((explicit-lisp-package-p (not (null lisp-package)))
+ (lisp-package
+ (or (and explicit-lisp-package-p (find-package lisp-package))
+ (make-package (gensym (string name))))))
+ (labels ((package-intern (string-like)
+ (intern (normalize string-like) lisp-package)))
+ (let ((script-package
+ (make-instance 'script-package
+ :name (normalize name)
+ :comp-env comp-env
+ :nicknames (mapcar #'normalize nicknames)
+ :lisp-package (find-package lisp-package)
+ :secondary-lisp-packages (mapcar #'find-package secondary-lisp-packages)
+ :exclusive-lisp-package? (not explicit-lisp-package-p)
+ :exports (mapcar #'package-intern exports)
+ :used-packages (mapcar #'(lambda (script-package-designator)
+ (find-script-package
+ script-package-designator comp-env))
+ used-packages)
+ :documentation documentation)))
+ (push script-package (comp-env-script-packages comp-env)))))))
+
+(defmethod initialize-instance :after ((package script-package) &key)
+ (assert (script-package-comp-env package))
+ (assert (script-package-lisp-package package))
+ (let ((lisp-packages (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
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *toplevel-special-forms* (make-hash-table)
+ "A hash-table containing functions that implement Parenscript special forms,
+indexed by name (as symbols)")
+
+ (defun undefine-script-special-form (name)
+ "Undefines the special form with the given name (name is a symbol)."
+ (declare (type symbol name))
+ (when (gethash name *toplevel-special-forms*)
+ (remhash name *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."
+ (declare (type symbol name))
+ (let ((script-name
+ (intern (format nil "PAREN-~A" (symbol-name name))
+ (find-package :parenscript)))
+ (arglist (gensym "ps-arglist-")))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun ,script-name (&rest ,arglist)
+ (destructuring-bind ,lambda-list
+ ,arglist
+ ,@body))
+ (setf (gethash (quote ,name) *toplevel-special-forms*) #',script-name))))
+
+(defun get-script-special-form (name)
+ "Returns the special form function corresponding to the given name."
+; (declare (type symbol name))
+ (when (symbolp name)
+ (gethash name *toplevel-special-forms*)))
+
+;;; sexp form predicates
+(defun script-special-form-p (form)
+ "Returns T if FORM is a special form and NIL otherwise."
+ (and (consp form)
+ (symbolp (car form))
+ (gethash (car form) *toplevel-special-forms*)))
+
+(defun funcall-form-p (form)
+ (and (listp form)
+ (not (op-form-p form))
+ (not (script-special-form-p form))))
+
+(defun method-call-p (form)
+ (and (funcall-form-p form)
+ (symbolp (first form))
+ (eql (char (symbol-name (first form)) 0) #\.)))
+
+;;; macro expansion
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun make-macro-env-dictionary ()
+ "Creates a standard macro dictionary."
+ (make-hash-table))
+ (defvar *script-macro-toplevel* (make-macro-env-dictionary)
+ "Toplevel macro environment dictionary. Key is symbol-name of the macro, value
+is (symbol-macro-p . expansion-function).")
+ (defvar *script-macro-env* (list *script-macro-toplevel*) ;(list nil)
+ "Current macro environment."))
+
+(defmacro get-macro-spec (name env-dict)
+ "Retrieves the macro spec of the given name with the given environment dictionary.
+SPEC is of the form (symbol-macro-op expansion-function)."
+ `(gethash ,name ,env-dict))
+
+(defun lookup-macro-spec (name &optional (environment *script-macro-env*))
+ "Looks up the macro spec associated with NAME in the given environment. A
+macro spec is of the form (symbol-macro-p function). Returns two values:
+the SPEC and the parent macro environment.
+
+NAME must be a symbol."
+ (when (symbolp name)
+ (do ((env environment (cdr env)))
+ ((null env) nil)
+ (let ((val (get-macro-spec name (car env))))
+ (when val
+ (return-from lookup-macro-spec
+ (values val (or (cdr env)
+ (list *script-macro-toplevel*)))))))))
+
+(defun script-symbol-macro-p (name &optional (environment *script-macro-env*))
+ "True if there is a Parenscript symbol macro named by the symbol NAME."
+ (and (symbolp name) (car (lookup-macro-spec name environment))))
+
+(defun script-macro-p (name &optional (environment *script-macro-env*))
+ "True if there is a Parenscript macro named by the symbol NAME."
+ (and (symbolp name)
+ (let ((macro-spec (lookup-macro-spec name environment)))
+ (and macro-spec (not (car macro-spec))))))
+
+(defun lookup-macro-expansion-function (name &optional (environment *script-macro-env*))
+ "Lookup NAME in the given macro expansion environment (which
+defaults to the current macro environment). Returns the expansion
+function and the parent macro environment of the macro."
+ (multiple-value-bind (macro-spec parent-env)
+ (lookup-macro-spec name environment)
+ (values (cdr macro-spec) parent-env)))
+
+(defmacro defscriptmacro (name args &body body)
+ "Define a ParenScript macro, and store it in the toplevel ParenScript
+macro environment."
+ (let ((lambda-list (gensym "ps-lambda-list-"))
+ (body (if (stringp (first body)) (rest body) body))) ;; drop docstring
+ (undefine-script-special-form name)
+ `(setf (get-macro-spec ',name *script-macro-toplevel*)
+ (cons nil (lambda (&rest ,lambda-list)
+ (destructuring-bind ,args
+ ,lambda-list
+ ,@body))))))
+
+(defmacro defpsmacro (name args &body body)
+ `(defscriptmacro (,name ,args ,@body)))
+
+(defun expand-script-form (expr)
+ "Expands a Parenscript form down to special forms."
+ (if (consp expr)
+ (let ((op (car expr))
+ (args (cdr expr)))
+ (cond ((equal op 'quote) expr) ;; leave quotes alone
+ ((script-macro-p op) ;; recursively expand parenscript macros in parent env.
+ (multiple-value-bind (expansion-function macro-env)
+ (lookup-macro-expansion-function op)
+ (expand-script-form (let ((*script-macro-env* macro-env))
+ (apply expansion-function args)))))
+ (t expr)))
+ ;; not a cons
+ (cond ((script-special-form-p expr)
+ ;; leave special forms alone (expanded during compile)
+ expr)
+ ((script-symbol-macro-p expr)
+ ;; recursively expand symbol macros in parent env.
+ (multiple-value-bind (expansion-function macro-env)
+ (lookup-macro-expansion-function expr)
+ (expand-script-form (let ((*script-macro-env* macro-env))
+ (funcall expansion-function)))))
+ ;; leave anything else alone
+ (t expr))))
+
+(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 &key toplevel-p)
+ (: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"))
+
+(defmethod compile-parenscript-form ((comp-env compilation-environment) form &key toplevel-p)
+ (setf form (expand-script-form form))
+ ;; ensures proper compilation environment TOPLEVEL-P slot value
+ (setf (comp-env-compiling-toplevel-p comp-env) toplevel-p)
+ (if
+ toplevel-p
+ (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 :toplevel-p t))
+ (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))
+ `(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))
+ (cond ((stringp form)
+ (make-instance 'string-literal :value form))
+ ((characterp form)
+ (make-instance 'string-literal :value (string form)))
+ ((numberp form)
+ (make-instance 'number-literal :value form))
+ ((symbolp form) ;; is this the correct behavior?
+ (let ((c-macro (get-script-special-form form)))
+ (if c-macro
+ (funcall c-macro)
+ (make-instance 'script-variable :value form))))
+ ((and (consp form)
+ (eql (first form) 'quote))
+ (make-instance 'script-quote :value (second form)))
+ ((consp form)
+ (let* ((name (car form))
+ (args (cdr form))
+ (script-form (get-script-special-form name)))
+ (cond (script-form
+ (apply script-form args))
+
+ ((op-form-p form)
+ (make-instance 'op-form
+ :operator (script-convert-op-name (compile-to-symbol (first form)))
+ :args (mapcar #'compile-to-expression (rest form))))
+
+ ((method-call-p form)
+ (make-instance 'method-call
+ :method (compile-to-symbol (first form))
+ :object (compile-to-expression (second form))
+ :args (mapcar #'compile-to-expression (cddr form))))
+
+ ((funcall-form-p form)
+ (make-instance 'function-call
+ :function (compile-to-expression (first form))
+ :args (mapcar #'compile-to-expression (rest form))))
+
+ (t (error "Unknown form ~S" form)))))
+ (t (error "Unknown atomar expression ~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 'expression))
+ res))
+
+(defun compile-to-symbol (form)
+ "Compiles the given Parenscript form and guarantees a symbolic result."
+ (let ((res (compile-script-form form)))
+ (when (typep res 'script-variable)
+ (setf res (value res)))
+ (assert (symbolp res) ()
+ "~a is expected to be a symbol, but compiles to ~a. This could be due to ~a being a special form." form res form)
+ 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 'statement))
+ res))
+
+(defun compile-to-body (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 'script-body)
+ (progn (setf (b-indent res) indent)
+ res)
+ (make-instance 'script-body
+ :indent indent
+ :statements (list res)))))
\ No newline at end of file
HCoop / clinton / parenscript.git / blobdiff