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