src/compiler.lisp

   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-string 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)))))