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