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     `(setf (gethash ',name *ps-special-forms*)
  27            (lambda (&rest ,args)
  28              (destructuring-bind ,(cons 'expecting lambda-list)
  29                  ,args
  30                (declare (ignorable expecting))
  31                ,@body)))))
  32
  33 (defun undefine-ps-special-form (name)
  34   (remhash name *ps-special-forms*))
  35
  36 (defun ps-special-form-p (form)
  37   (and (consp form)
  38        (symbolp (car form))
  39        (gethash (car form) *ps-special-forms*)))
  40
  41 ;;; scoping
  42
  43 (defvar *enclosing-lexical-block-declarations* ()
  44   "This special variable is expected to be bound to a fresh list by
  45 special forms that introduce a new JavaScript lexical block (currently
  46 function definitions and lambdas). Enclosed special forms are expected
  47 to push variable declarations onto the list when the variables
  48 declaration cannot be made by the enclosed form \(for example, a
  49 \(x,y,z\) expression progn\). It is then the responsibility of the
  50 enclosing special form to introduce the variable bindings in its
  51 lexical block.")
  52
  53 (defvar *ps-special-variables* ())
  54
  55 (defun ps-special-variable-p (sym)
  56   (member sym *ps-special-variables*))
  57
  58 ;;; form predicates
  59
  60 (defun op-form-p (form)
  61   (and (listp form)
  62        (not (ps-special-form-p form))
  63        (not (null (op-precedence (first form))))))
  64
  65 (defun funcall-form-p (form)
  66   (and (listp form)
  67        (not (op-form-p form))
  68        (not (ps-special-form-p form))))
  69
  70 ;;; macro expansion
  71 (eval-when (:compile-toplevel :load-toplevel :execute)
  72   (defun make-macro-env-dictionary ()
  73     (make-hash-table :test 'eq))
  74   (defvar *ps-macro-toplevel* (make-macro-env-dictionary)
  75     "Toplevel macro environment dictionary. Key is the symbol name of
  76     the macro, value is (symbol-macro-p . expansion-function).")
  77
  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   (defparameter *toplevel-compilation-level* :toplevel
  88     "This value takes on the following values:
  89 :toplevel indicates that we are traversing toplevel forms.
  90 :inside-toplevel-form indicates that we are inside a call to compile-parenscript-form
  91 nil indicates we are no longer toplevel-related.")
  92
  93   (defun get-macro-spec (name env-dict)
  94     "Retrieves the macro spec of the given name with the given environment dictionary.
  95 SPEC is of the form (symbol-macro-p . expansion-function)."
  96     (gethash name env-dict))
  97   (defsetf get-macro-spec (name env-dict)
  98       (spec)
  99     `(setf (gethash ,name ,env-dict) ,spec)))
 100
 101 (defun lookup-macro-spec (name &optional (environment *ps-macro-env*))
 102   "Looks up the macro spec associated with NAME in the given environment.  A
 103 macro spec is of the form (symbol-macro-p . function). Returns two values:
 104 the SPEC and the parent macro environment.
 105
 106 NAME must be a symbol."
 107   (when (symbolp name)
 108     (do ((env environment (cdr env)))
 109         ((null env) nil)
 110       (let ((val (get-macro-spec name (car env))))
 111         (when val
 112           (return-from lookup-macro-spec
 113             (values val (or (cdr env)
 114                             (list *ps-macro-toplevel*)))))))))
 115
 116 (defun ps-symbol-macro-p (name &optional (environment *ps-macro-env*))
 117   "True if there is a Parenscript symbol macro named by the symbol NAME."
 118   (and (symbolp name) (car (lookup-macro-spec name environment))))
 119
 120 (defun ps-macro-p (name &optional (environment *ps-macro-env*))
 121   "True if there is a Parenscript macro named by the symbol NAME."
 122   (and (symbolp name)
 123        (let ((macro-spec (lookup-macro-spec name environment)))
 124          (and macro-spec (not (car macro-spec))))))
 125
 126 (defun lookup-macro-expansion-function (name &optional (environment *ps-macro-env*))
 127   "Lookup NAME in the given macro expansion environment (which
 128 defaults to the current macro environment). Returns the expansion
 129 function and the parent macro environment of the macro."
 130   (multiple-value-bind (macro-spec parent-env)
 131       (lookup-macro-spec name environment)
 132     (values (cdr macro-spec) parent-env)))
 133
 134 (defun make-ps-macro-function (args body)
 135   (let* ((whole-var (when (eql '&whole (first args)) (second args)))
 136          (effective-lambda-list (if whole-var (cddr args) args))
 137          (whole-arg (or whole-var (gensym "ps-macro-form-arg-"))))
 138     `(lambda (,whole-arg)
 139        (destructuring-bind ,effective-lambda-list
 140            (cdr ,whole-arg)
 141          ,@body))))
 142
 143 (defmacro defpsmacro (name args &body body)
 144   `(progn (undefine-ps-special-form ',name)
 145           (setf (get-macro-spec ',name *ps-macro-toplevel*)
 146                 (cons nil ,(make-ps-macro-function args body)))
 147           ',name))
 148
 149 (defmacro define-ps-symbol-macro (symbol expansion)
 150   (let ((x (gensym)))
 151     `(progn (undefine-ps-special-form ',symbol)
 152             (setf (get-macro-spec ',symbol *ps-macro-toplevel*) (cons t (lambda (,x) (declare (ignore ,x)) ',expansion)))
 153             ',symbol)))
 154
 155 (defun import-macros-from-lisp (&rest names)
 156   "Import the named Lisp macros into the ParenScript macro
 157 environment. When the imported macro is macroexpanded by ParenScript,
 158 it is first fully macroexpanded in the Lisp macro environment, and
 159 then that expansion is further expanded by ParenScript."
 160   (dolist (name names)
 161     (eval `(defpsmacro ,name (&rest args)
 162              (macroexpand `(,',name ,@args))))))
 163
 164 (defmacro defmacro/ps (name args &body body)
 165   "Define a Lisp macro and import it into the ParenScript macro environment."
 166   `(progn (defmacro ,name ,args ,@body)
 167           (import-macros-from-lisp ',name)))
 168
 169 (defmacro defmacro+ps (name args &body body)
 170   "Define a Lisp macro and a ParenScript macro with the same macro
 171 function (ie - the same result from macroexpand-1), for cases when the
 172 two have different full macroexpansions (for example if the CL macro
 173 contains implementation-specific code when macroexpanded fully in the
 174 CL environment)."
 175   `(progn (defmacro ,name ,args ,@body)
 176           (defpsmacro ,name ,args ,@body)))
 177
 178 (defun ps-macroexpand (form)
 179   "Recursively macroexpands ParenScript macros and symbol-macros in
 180 the given ParenScript form. Returns two values: the expanded form, and
 181 whether any expansion was performed on the form or not."
 182   (let ((macro-function (cond ((ps-symbol-macro-p form) form)
 183                               ((and (consp form) (ps-macro-p (car form))) (car form)))))
 184     (if macro-function
 185         (values (ps-macroexpand (funcall (lookup-macro-expansion-function macro-function) form)) t)
 186         (values form nil))))
 187
 188 ;;;; compiler interface
 189 (defgeneric compile-parenscript-form (form &key expecting)
 190   (:documentation "Compiles a ParenScript form to the intermediate
 191 ParenScript representation. :expecting determines whether the form is
 192 compiled to an :expression (the default), a :statement, or a
 193 :symbol."))
 194
 195 (defun adjust-toplevel-compilation-level (form level)
 196   (let ((default-level (if (eql :toplevel level)
 197                            :inside-toplevel-form
 198                            nil)))
 199     (if (consp form)
 200         (case (car form)
 201           ('progn level)
 202           (t default-level))
 203         default-level)))
 204
 205 (defmethod compile-parenscript-form :around (form &key expecting)
 206   (assert (if expecting (member expecting '(:expression :statement :symbol)) t))
 207   (if (eql expecting :symbol)
 208       (compile-to-symbol form)
 209       (multiple-value-bind (expanded-form expanded-p)
 210           (ps-macroexpand form)
 211         (if expanded-p
 212             (compile-parenscript-form expanded-form :expecting expecting)
 213             (let ((*toplevel-compilation-level*
 214                    (progn
 215                      (adjust-toplevel-compilation-level form *toplevel-compilation-level*))))
 216               (call-next-method))))))
 217
 218 (defun compile-to-symbol (form)
 219   "Compiles the given Parenscript form and guarantees that the
 220 resultant symbol has an associated script-package. Raises an error if
 221 the form cannot be compiled to a symbol."
 222   (let ((exp (compile-parenscript-form form)))
 223     (when (eq (first exp) 'js:variable)
 224       (setf exp (second exp)))
 225     (assert (symbolp exp) ()
 226             "~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)
 227     exp))
 228
 229 (defmethod compile-parenscript-form (form &key expecting)
 230   (declare (ignore expecting))
 231   (error "The object ~S cannot be compiled by ParenScript." form))
 232
 233 (defmethod compile-parenscript-form ((form number) &key expecting)
 234   (declare (ignore expecting))
 235   form)
 236
 237 (defmethod compile-parenscript-form ((form string) &key expecting)
 238   (declare (ignore expecting))
 239   form)
 240
 241 (defmethod compile-parenscript-form ((form character) &key expecting)
 242   (declare (ignore expecting))
 243   (compile-parenscript-form (string form)))
 244
 245 (defmethod compile-parenscript-form ((symbol symbol) &key expecting)
 246   (declare (ignore expecting))
 247   (cond ((keywordp symbol) symbol)
 248         ((ps-special-form-p (list symbol))
 249          (if (ps-literal-p symbol)
 250              (funcall (get-ps-special-form symbol) :symbol)
 251              (error "Attempting to use Parenscript special form ~a as variable" symbol)))
 252         (t `(js:variable ,symbol))))
 253
 254 (defun ps-convert-op-name (op)
 255   (case op
 256     (and '\&\&)
 257     (or '\|\|)
 258     (not '!)
 259     (eql '\=\=)
 260     (=   '\=\=)
 261     (t op)))
 262
 263 (defmethod compile-parenscript-form ((form cons) &key (expecting :statement))
 264   (let* ((name (car form))
 265          (args (cdr form)))
 266     (cond ((ps-special-form-p form) (apply (get-ps-special-form name) (cons expecting args)))
 267           ((op-form-p form)
 268            `(js:operator
 269                  ,(ps-convert-op-name (compile-parenscript-form (first form) :expecting :symbol))
 270                  ,@(mapcar (lambda (form) (compile-parenscript-form form :expecting :expression)) (rest form))))
 271           ((funcall-form-p form)
 272            `(js:funcall ,(compile-parenscript-form name :expecting :expression)
 273              ,@(mapcar (lambda (arg) (compile-parenscript-form arg :expecting :expression)) args)))
 274           (t (error "Cannot compile ~S to a ParenScript form." form)))))
 275
 276 (defvar *ps-gensym-counter* 0)
 277
 278 (defun ps-gensym (&optional (prefix "_js"))
 279   (let ((prefix (if (stringp prefix) prefix (symbol-to-js-string prefix nil))))
 280     (make-symbol (format nil "~A~:[~;_~]~A" prefix
 281                          (digit-char-p (char prefix (1- (length prefix))))
 282                          (incf *ps-gensym-counter*)))))
 283
 284 (defmacro with-ps-gensyms (symbols &body body)
 285   "Evaluate BODY with SYMBOLS bound to unique ParenScript identifiers.
 286
 287 Each element of SYMBOLS is either a symbol or a list of (symbol
 288 gensym-prefix-string)."
 289   `(let* ,(mapcar (lambda (symbol)
 290                     (destructuring-bind (symbol &optional prefix)
 291                         (if (consp symbol)
 292                             symbol
 293                             (list symbol))
 294                       (if prefix
 295                           `(,symbol (ps-gensym ,prefix))
 296                           `(,symbol (ps-gensym ,(symbol-to-js-string symbol))))))
 297                   symbols)
 298      ,@body))
 299
 300 (defun %check-once-only-vars (vars)
 301   (let ((bad-var (find-if (lambda (x) (or (not (symbolp x)) (keywordp x))) vars)))
 302     (when bad-var
 303       (error "PS-ONLY-ONCE expected a non-keyword symbol but got ~s" bad-var))))
 304
 305 (defmacro ps-once-only ((&rest vars) &body body)
 306   (%check-once-only-vars vars)
 307   (let ((gensyms (mapcar (lambda (x) (ps-gensym (string x))) vars)))
 308     `(let ,(mapcar (lambda (g v) `(,g (ps-gensym ,(string v)))) gensyms vars)
 309        `(let* (,,@(mapcar (lambda (g v) ``(,,g ,,v)) gensyms vars))
 310           ,(let ,(mapcar (lambda (g v) `(,v ,g)) gensyms vars)
 311              ,@body)))))
 312
 313 (defvar *read-function* #'read
 314   "This should be a function that takes the same inputs and returns the same
 315 outputs as the common lisp read function.  We declare it as a variable to allow
 316 a user-supplied reader instead of the default lisp reader.")
 317
 318 (defun ps-compile-stream (stream)
 319   "Compiles a source stream as if it were a file.  Outputs a Javascript string."
 320
 321   (let ((*toplevel-compilation-level* :toplevel)
 322         (*package* *package*)
 323         (end-read-form '#:unique))
 324     (flet ((read-form () (funcall *read-function* stream nil end-read-form)))
 325       (let* ((js-string
 326               ;; cons up the forms, compiling as we go, and print the result
 327               (do ((form (read-form) (read-form))
 328                    (compiled-forms nil))
 329                   ((eql form end-read-form)
 330                      (format nil "~{~A~^;~%~}"
 331                              (remove-if
 332                               #'(lambda (x) (or (null x) (= 0 (length x))))
 333                               (mapcar 'compiled-form-to-string (nreverse compiled-forms)))))
 334                 (push (compile-parenscript-form form :expecting :statement) compiled-forms))))
 335         js-string))))
 336
 337
 338 (defun ps-compile-file (source-file)
 339   "Compiles the given Parenscript source file and returns a Javascript string."
 340   (with-open-file (stream source-file :direction :input)
 341     (ps-compile-stream stream)))
 342