src/compiler.lisp

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