| 1 | (in-package :parenscript) |
| 2 | |
| 3 | (defvar *ps-literals* ()) |
| 4 | (defvar *ps-special-forms* ()) |
| 5 | |
| 6 | (defun undefine-ps-special-form (name) |
| 7 | "Undefines the special form with the given name (name is a symbol)." |
| 8 | (setf *ps-special-forms* (delete name *ps-special-forms*) |
| 9 | *ps-literals* (delete name *ps-literals*)) |
| 10 | (unintern (lisp-symbol-to-ps-identifier name :special-form) :parenscript-special-forms)) |
| 11 | |
| 12 | (defmacro define-ps-special-form (name lambda-list &rest body) |
| 13 | "Define a special form NAME. The first argument given to the special |
| 14 | form is a keyword indicating whether the form is expected to produce |
| 15 | an :expression or a :statement. The resulting Parenscript language |
| 16 | types are appended to the ongoing javascript compilation." |
| 17 | (let ((arglist (gensym "ps-arglist-"))) |
| 18 | `(progn (pushnew ',name *ps-special-forms*) |
| 19 | (defun ,(lisp-symbol-to-ps-identifier name :special-form) (&rest ,arglist) |
| 20 | (destructuring-bind ,lambda-list |
| 21 | ,arglist |
| 22 | ,@body))))) |
| 23 | |
| 24 | (defun get-ps-special-form (name) |
| 25 | "Returns the special form function corresponding to the given name." |
| 26 | (lisp-symbol-to-ps-identifier name :special-form)) |
| 27 | |
| 28 | (defvar *enclosing-lexical-block-declarations* () |
| 29 | "This special variable is expected to be bound to a fresh list by |
| 30 | special forms that introduce a new JavaScript lexical block (currently |
| 31 | function definitions and lambdas). Enclosed special forms are expected |
| 32 | to push variable declarations onto the list when the variables |
| 33 | declaration cannot be made by the enclosed form (for example, a |
| 34 | (x,y,z) expression progn). It is then the responsibility of the |
| 35 | enclosing special form to introduce the variable bindings in its |
| 36 | lexical block.") |
| 37 | |
| 38 | (defvar *ps-special-variables* ()) |
| 39 | |
| 40 | ;;; ParenScript form predicates |
| 41 | (defun ps-special-form-p (form) |
| 42 | (and (consp form) |
| 43 | (symbolp (car form)) |
| 44 | (member (car form) *ps-special-forms*))) |
| 45 | |
| 46 | (defun ps-literal-p (symbol) |
| 47 | (member symbol *ps-literals*)) |
| 48 | |
| 49 | (defun op-form-p (form) |
| 50 | (and (listp form) |
| 51 | (not (ps-special-form-p form)) |
| 52 | (not (null (op-precedence (first form)))))) |
| 53 | |
| 54 | (defun funcall-form-p (form) |
| 55 | (and (listp form) |
| 56 | (not (op-form-p form)) |
| 57 | (not (ps-special-form-p form)))) |
| 58 | |
| 59 | (defun method-call-p (form) |
| 60 | (and (funcall-form-p form) |
| 61 | (symbolp (first form)) |
| 62 | (eql (char (symbol-name (first form)) 0) #\.))) |
| 63 | |
| 64 | ;;; macro expansion |
| 65 | (eval-when (:compile-toplevel :load-toplevel :execute) |
| 66 | (defun make-macro-env-dictionary () |
| 67 | "Creates a standard macro dictionary." |
| 68 | (make-hash-table :test #'equal)) |
| 69 | (defvar *script-macro-toplevel* (make-macro-env-dictionary) |
| 70 | "Toplevel macro environment dictionary. Key is the symbol of the |
| 71 | macro, value is (symbol-macro-p . expansion-function).") |
| 72 | (defvar *script-macro-env* (list *script-macro-toplevel*) |
| 73 | "Current macro environment.") |
| 74 | |
| 75 | (defvar *script-setf-expanders* (make-macro-env-dictionary) |
| 76 | "Setf expander dictionary. Key is the symbol of the access |
| 77 | function of the place, value is an expansion function that takes the |
| 78 | arguments of the access functions as a first value and the form to be |
| 79 | stored as the second value.") |
| 80 | |
| 81 | (defun get-macro-spec (name env-dict) |
| 82 | "Retrieves the macro spec of the given name with the given environment dictionary. |
| 83 | SPEC is of the form (symbol-macro-p . expansion-function)." |
| 84 | (gethash (lisp-symbol-to-ps-identifier name :macro) env-dict)) |
| 85 | (defsetf get-macro-spec (name env-dict) |
| 86 | (spec) |
| 87 | `(setf (gethash (lisp-symbol-to-ps-identifier ,name :macro) ,env-dict) ,spec))) |
| 88 | |
| 89 | (defun lookup-macro-spec (name &optional (environment *script-macro-env*)) |
| 90 | "Looks up the macro spec associated with NAME in the given environment. A |
| 91 | macro spec is of the form (symbol-macro-p . function). Returns two values: |
| 92 | the SPEC and the parent macro environment. |
| 93 | |
| 94 | NAME must be a symbol." |
| 95 | (when (symbolp name) |
| 96 | (do ((env environment (cdr env))) |
| 97 | ((null env) nil) |
| 98 | (let ((val (get-macro-spec name (car env)))) |
| 99 | (when val |
| 100 | (return-from lookup-macro-spec |
| 101 | (values val (or (cdr env) |
| 102 | (list *script-macro-toplevel*))))))))) |
| 103 | |
| 104 | (defun script-symbol-macro-p (name &optional (environment *script-macro-env*)) |
| 105 | "True if there is a Parenscript symbol macro named by the symbol NAME." |
| 106 | (and (symbolp name) (car (lookup-macro-spec name environment)))) |
| 107 | |
| 108 | (defun script-macro-p (name &optional (environment *script-macro-env*)) |
| 109 | "True if there is a Parenscript macro named by the symbol NAME." |
| 110 | (and (symbolp name) |
| 111 | (let ((macro-spec (lookup-macro-spec name environment))) |
| 112 | (and macro-spec (not (car macro-spec)))))) |
| 113 | |
| 114 | (defun lookup-macro-expansion-function (name &optional (environment *script-macro-env*)) |
| 115 | "Lookup NAME in the given macro expansion environment (which |
| 116 | defaults to the current macro environment). Returns the expansion |
| 117 | function and the parent macro environment of the macro." |
| 118 | (multiple-value-bind (macro-spec parent-env) |
| 119 | (lookup-macro-spec name environment) |
| 120 | (values (cdr macro-spec) parent-env))) |
| 121 | |
| 122 | (eval-when (:compile-toplevel :load-toplevel :execute) |
| 123 | (defun make-ps-macro-function (args body) |
| 124 | (let* ((whole-var (when (eql '&whole (first args)) (second args))) |
| 125 | (effective-lambda-list (if whole-var (cddr args) args)) |
| 126 | (form-arg (or whole-var (gensym "ps-macro-form-arg-"))) |
| 127 | (body (if (and (cdr body) (stringp (first body))) (rest body) body))) ;; drop docstring |
| 128 | (compile nil `(lambda (,form-arg) |
| 129 | (destructuring-bind ,effective-lambda-list |
| 130 | (cdr ,form-arg) |
| 131 | ,@body))))) |
| 132 | |
| 133 | (defun define-script-macro% (name args body &key symbol-macro-p) |
| 134 | (undefine-ps-special-form name) |
| 135 | (setf (get-macro-spec name *script-macro-toplevel*) |
| 136 | (cons symbol-macro-p (make-ps-macro-function args body))) |
| 137 | nil)) |
| 138 | |
| 139 | (defmacro defpsmacro (name args &body body) |
| 140 | "Define a ParenScript macro, and store it in the toplevel ParenScript |
| 141 | macro environment." |
| 142 | `(define-script-macro% ',name ',args ',body :symbol-macro-p nil)) |
| 143 | |
| 144 | (defmacro define-script-symbol-macro (name &body body) |
| 145 | "Define a ParenScript symbol macro, and store it in the toplevel ParenScript |
| 146 | macro environment. BODY is a Lisp form that should return a ParenScript form." |
| 147 | `(define-script-macro% ',name () ',body :symbol-macro-p t)) |
| 148 | |
| 149 | (defun import-macros-from-lisp (&rest names) |
| 150 | "Import the named Lisp macros into the ParenScript macro |
| 151 | environment. When the imported macro is macroexpanded by ParenScript, |
| 152 | it is first fully macroexpanded in the Lisp macro environment, and |
| 153 | then that expansion is further expanded by ParenScript." |
| 154 | (dolist (name names) |
| 155 | (define-script-macro% name '(&rest args) |
| 156 | (list `(common-lisp:macroexpand `(,',name ,@args))) |
| 157 | :symbol-macro-p nil))) |
| 158 | |
| 159 | (defmacro defmacro/ps (name args &body body) |
| 160 | "Define a Lisp macro and import it into the ParenScript macro environment." |
| 161 | `(progn (defmacro ,name ,args ,@body) |
| 162 | (ps:import-macros-from-lisp ',name))) |
| 163 | |
| 164 | (defmacro defmacro+ps (name args &body body) |
| 165 | "Define a Lisp macro and a ParenScript macro in their respective |
| 166 | macro environments. This function should be used when you want to use |
| 167 | the same macro in both Lisp and ParenScript, but the 'macroexpand' of |
| 168 | that macro in Lisp makes the Lisp macro unsuitable to be imported into |
| 169 | the ParenScript macro environment." |
| 170 | `(progn (defmacro ,name ,args ,@body) |
| 171 | (defpsmacro ,name ,args ,@body))) |
| 172 | |
| 173 | (defun ps-macroexpand (form) |
| 174 | "Recursively macroexpands ParenScript macros and symbol-macros in |
| 175 | the given ParenScript form. Returns two values: the expanded form, and |
| 176 | whether any expansion was performed on the form or not." |
| 177 | (if (consp form) |
| 178 | (let ((op (car form)) |
| 179 | (args (cdr form))) |
| 180 | (cond ((equal op 'quote) (values (if (equalp '(nil) args) nil form) ; leave quotes alone, unless it's a quoted nil |
| 181 | nil)) |
| 182 | ((script-macro-p op) (values (ps-macroexpand (funcall (lookup-macro-expansion-function op) form)) t)) |
| 183 | (t (values form nil)))) |
| 184 | (cond ((script-symbol-macro-p form) (values (ps-macroexpand (funcall (lookup-macro-expansion-function form) (list form))) t)) |
| 185 | (t (values form nil))))) |
| 186 | |
| 187 | ;;;; compiler interface |
| 188 | (defgeneric compile-parenscript-form (form &key expecting) |
| 189 | (:documentation "Compiles a ParenScript form to the intermediate |
| 190 | ParenScript representation. :expecting determines whether the form is |
| 191 | compiled to an :expression (the default), a :statement, or a |
| 192 | :symbol.")) |
| 193 | |
| 194 | (defmethod compile-parenscript-form :around (form &key expecting) |
| 195 | (assert (if expecting (member expecting '(:expression :statement :symbol)) t)) |
| 196 | (if (eql expecting :symbol) |
| 197 | (compile-to-symbol form) |
| 198 | (multiple-value-bind (expanded-form expanded-p) |
| 199 | (ps-macroexpand form) |
| 200 | (if expanded-p |
| 201 | (compile-parenscript-form expanded-form :expecting expecting) |
| 202 | (call-next-method))))) |
| 203 | |
| 204 | (defun compile-to-symbol (form) |
| 205 | "Compiles the given Parenscript form and guarantees that the |
| 206 | resultant symbol has an associated script-package. Raises an error if |
| 207 | the form cannot be compiled to a symbol." |
| 208 | (let ((exp (compile-parenscript-form form))) |
| 209 | (when (or (eql (first exp) 'js-variable) |
| 210 | (eql (first exp) 'script-quote)) |
| 211 | (setf exp (second exp))) |
| 212 | (assert (symbolp exp) () |
| 213 | "~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) |
| 214 | exp)) |
| 215 | |
| 216 | (defmethod compile-parenscript-form (form &key expecting) |
| 217 | (declare (ignore expecting)) |
| 218 | (error "The object ~S cannot be compiled by ParenScript." form)) |
| 219 | |
| 220 | (defmethod compile-parenscript-form ((form number) &key expecting) |
| 221 | (declare (ignore expecting)) |
| 222 | form) |
| 223 | |
| 224 | (defmethod compile-parenscript-form ((form string) &key expecting) |
| 225 | (declare (ignore expecting)) |
| 226 | form) |
| 227 | |
| 228 | (defmethod compile-parenscript-form ((form character) &key expecting) |
| 229 | (declare (ignore expecting)) |
| 230 | (compile-parenscript-form (string form))) |
| 231 | |
| 232 | (defmethod compile-parenscript-form ((symbol symbol) &key expecting) |
| 233 | (declare (ignore expecting)) |
| 234 | (cond ((ps-special-form-p (list symbol)) |
| 235 | (if (ps-literal-p symbol) |
| 236 | (funcall (get-ps-special-form symbol) :symbol) |
| 237 | (error "Attempting to use Parenscript special form ~a as variable" symbol))) |
| 238 | (t (list 'js-variable symbol)))) |
| 239 | |
| 240 | (defun compile-function-argument-forms (arg-forms) |
| 241 | "Compiles a bunch of Parenscript forms from a funcall form to an effective set of |
| 242 | Javascript arguments. The only extra processing this does is makes :keyword arguments |
| 243 | into a single options argument via CREATE." |
| 244 | (flet ((keyword-arg (arg) |
| 245 | "If the given compiled expression is supposed to be a keyword argument, returns |
| 246 | the keyword for it." |
| 247 | (when (and (listp arg) (eql (first arg) 'script-quote)) (second arg)))) |
| 248 | (let ((compiled-args (mapcar (lambda (arg) (compile-parenscript-form arg :expecting :expression)) |
| 249 | arg-forms))) |
| 250 | (do ((effective-expressions nil) |
| 251 | (expressions-subl compiled-args)) |
| 252 | ((not expressions-subl) (reverse effective-expressions)) |
| 253 | (let ((arg-expr (first expressions-subl))) |
| 254 | (if (keyword-arg arg-expr) |
| 255 | (progn (when (oddp (length expressions-subl)) |
| 256 | (error "Odd number of keyword arguments: ~A." arg-forms)) |
| 257 | (push (list 'js-object (loop for (name val) on expressions-subl by #'cddr |
| 258 | collect (list name val))) |
| 259 | effective-expressions) |
| 260 | (setf expressions-subl nil)) |
| 261 | (progn (push arg-expr effective-expressions) |
| 262 | (setf expressions-subl (rest expressions-subl))))))))) |
| 263 | |
| 264 | (defmethod compile-parenscript-form ((form cons) &key (expecting :statement)) |
| 265 | (let* ((name (car form)) |
| 266 | (args (cdr form))) |
| 267 | (cond ((eql name 'quote) |
| 268 | (assert (= 1 (length args)) () "Wrong number of arguments to quote: ~s" args) |
| 269 | (list 'script-quote (first args))) |
| 270 | ((ps-special-form-p form) (apply (get-ps-special-form name) (cons expecting args))) |
| 271 | ((op-form-p form) |
| 272 | (list 'operator |
| 273 | (script-convert-op-name (compile-parenscript-form (first form) :expecting :symbol)) |
| 274 | (mapcar (lambda (form) (compile-parenscript-form form :expecting :expression)) (rest form)))) |
| 275 | ((method-call-p form) |
| 276 | (list 'js-method-call |
| 277 | (compile-parenscript-form name :expecting :symbol) |
| 278 | (compile-parenscript-form (first args) :expecting :expression) |
| 279 | (compile-function-argument-forms (rest args)))) |
| 280 | ((funcall-form-p form) |
| 281 | (list 'js-funcall |
| 282 | (compile-parenscript-form name :expecting :expression) |
| 283 | (compile-function-argument-forms args))) |
| 284 | (t (error "Cannot compile ~S to a ParenScript form." form))))) |
| 285 | |
| 286 | (defvar *ps-gensym-counter* 0) |
| 287 | |
| 288 | (defun ps-gensym (&optional (prefix "_js")) |
| 289 | (make-symbol (format nil "~A~A" prefix (incf *ps-gensym-counter*)))) |
| 290 | |
| 291 | (defmacro with-ps-gensyms (symbols &body body) |
| 292 | "Evaluate BODY with SYMBOLS bound to unique ParenScript identifiers. |
| 293 | |
| 294 | Each element of SYMBOLS is either a symbol or a list of (symbol |
| 295 | gensym-prefix-string)." |
| 296 | `(let* ,(mapcar (lambda (symbol) |
| 297 | (destructuring-bind (symbol &optional prefix) |
| 298 | (if (consp symbol) |
| 299 | symbol |
| 300 | (list symbol)) |
| 301 | (if prefix |
| 302 | `(,symbol (ps-gensym ,prefix)) |
| 303 | `(,symbol (ps-gensym ,(symbol-to-js symbol)))))) |
| 304 | symbols) |
| 305 | ,@body)) |