src/parser.lisp

   1 (in-package :parenscript)
   2
   3 ;;;; The mechanisms for defining macros & parsing Parenscript.
   4 (eval-when (:compile-toplevel :load-toplevel :execute)
   5   (defvar *toplevel-special-forms* (make-hash-table :test #'equal)
   6     "A hash-table containing functions that implement Parenscript special forms,
   7 indexed by name (as symbols)")
   8   (defun undefine-ps-special-form (name)
   9     "Undefines the special form with the given name (name is a symbol)."
  10     (remhash (lisp-symbol-to-ps-identifier name :special-form) *toplevel-special-forms*)))
  11
  12 (defmacro define-ps-special-form (name lambda-list &rest body)
  13   "Define a special form NAME. The first argument given to the special
  14 form is a keyword indicating whether the form is expected to produce
  15 an :expression or a :statement. The resulting Parenscript language
  16 types are appended to the ongoing javascript compilation."
  17   (let ((arglist (gensym "ps-arglist-")))
  18     `(setf (gethash (lisp-symbol-to-ps-identifier ',name :special-form) *toplevel-special-forms*)
  19       (lambda (&rest ,arglist)
  20         (destructuring-bind ,lambda-list
  21             ,arglist
  22           ,@body)))))
  23
  24 (defun get-ps-special-form (name)
  25   "Returns the special form function corresponding to the given name."
  26   (gethash (lisp-symbol-to-ps-identifier name :special-form) *toplevel-special-forms*))
  27
  28 ;;; ParenScript form predicates
  29 (defun ps-special-form-p (form)
  30   (and (consp form)
  31        (symbolp (car form))
  32        (get-ps-special-form (car form))))
  33
  34 (defun op-form-p (form)
  35   (and (listp form)
  36        (not (ps-special-form-p form))
  37        (not (null (op-precedence (first form))))))
  38
  39 (defun funcall-form-p (form)
  40   (and (listp form)
  41        (not (op-form-p form))
  42        (not (ps-special-form-p form))))
  43
  44 (defun method-call-p (form)
  45   (and (funcall-form-p form)
  46        (symbolp (first form))
  47        (eql (char (symbol-name (first form)) 0) #\.)))
  48
  49 ;;; macro expansion
  50 (eval-when (:compile-toplevel :load-toplevel :execute)
  51   (defun make-macro-env-dictionary ()
  52     "Creates a standard macro dictionary."
  53     (make-hash-table :test #'equal))
  54   (defvar *script-macro-toplevel* (make-macro-env-dictionary)
  55     "Toplevel macro environment dictionary. Key is the symbol of the
  56 macro, value is (symbol-macro-p . expansion-function).")
  57   (defvar *script-macro-env* (list *script-macro-toplevel*)
  58     "Current macro environment.")
  59
  60   (defvar *script-setf-expanders* (make-macro-env-dictionary)
  61     "Setf expander dictionary. Key is the symbol of the access
  62 function of the place, value is an expansion function that takes the
  63 arguments of the access functions as a first value and the form to be
  64 stored as the second value.")
  65
  66   (defun get-macro-spec (name env-dict)
  67     "Retrieves the macro spec of the given name with the given environment dictionary.
  68 SPEC is of the form (symbol-macro-p . expansion-function)."
  69     (gethash (lisp-symbol-to-ps-identifier name :macro) env-dict))
  70   (defsetf get-macro-spec (name env-dict)
  71       (spec)
  72     `(setf (gethash (lisp-symbol-to-ps-identifier ,name :macro) ,env-dict) ,spec)))
  73
  74 (defun lookup-macro-spec (name &optional (environment *script-macro-env*))
  75   "Looks up the macro spec associated with NAME in the given environment.  A
  76 macro spec is of the form (symbol-macro-p . function). Returns two values:
  77 the SPEC and the parent macro environment.
  78
  79 NAME must be a symbol."
  80   (when (symbolp name)
  81     (do ((env environment (cdr env)))
  82         ((null env) nil)
  83       (let ((val (get-macro-spec name (car env))))
  84         (when val
  85           (return-from lookup-macro-spec
  86             (values val (or (cdr env)
  87                             (list *script-macro-toplevel*)))))))))
  88
  89 (defun script-symbol-macro-p (name &optional (environment *script-macro-env*))
  90   "True if there is a Parenscript symbol macro named by the symbol NAME."
  91   (and (symbolp name) (car (lookup-macro-spec name environment))))
  92
  93 (defun script-macro-p (name &optional (environment *script-macro-env*))
  94   "True if there is a Parenscript macro named by the symbol NAME."
  95   (and (symbolp name)
  96        (let ((macro-spec (lookup-macro-spec name environment)))
  97          (and macro-spec (not (car macro-spec))))))
  98
  99 (defun lookup-macro-expansion-function (name &optional (environment *script-macro-env*))
 100   "Lookup NAME in the given macro expansion environment (which
 101 defaults to the current macro environment). Returns the expansion
 102 function and the parent macro environment of the macro."
 103   (multiple-value-bind (macro-spec parent-env)
 104       (lookup-macro-spec name environment)
 105     (values (cdr macro-spec) parent-env)))
 106
 107 (eval-when (:compile-toplevel :load-toplevel :execute)
 108   (defun define-script-macro% (name args body &key symbol-macro-p)
 109     (let ((lambda-list (gensym "ps-lambda-list-"))
 110           (body (if (and (cdr body) (stringp (first body))) (rest body) body))) ;; drop docstring
 111       (undefine-ps-special-form name)
 112       (setf (get-macro-spec name *script-macro-toplevel*)
 113             (cons symbol-macro-p (compile nil `(lambda (&rest ,lambda-list)
 114                                                 (destructuring-bind ,args
 115                                                     ,lambda-list
 116                                                   ,@body)))))
 117       nil)))
 118
 119 (defmacro defpsmacro (name args &body body)
 120   "Define a ParenScript macro, and store it in the toplevel ParenScript
 121 macro environment."
 122   `(define-script-macro% ',name ',args ',body :symbol-macro-p nil))
 123
 124 (defmacro define-script-symbol-macro (name &body body)
 125   "Define a ParenScript symbol macro, and store it in the toplevel ParenScript
 126 macro environment.  BODY is a Lisp form that should return a ParenScript form."
 127   `(define-script-macro% ',name () ',body :symbol-macro-p t))
 128
 129 (defun import-macros-from-lisp (&rest names)
 130   "Import the named Lisp macros into the ParenScript macro
 131 environment. When the imported macro is macroexpanded by ParenScript,
 132 it is first fully macroexpanded in the Lisp macro environment, and
 133 then that expansion is further expanded by ParenScript."
 134   (dolist (name names)
 135     (define-script-macro% name '(&rest args)
 136       (list `(common-lisp:macroexpand `(,',name ,@args)))
 137       :symbol-macro-p nil)))
 138
 139 (defmacro defmacro/ps (name args &body body)
 140   "Define a Lisp macro and import it into the ParenScript macro environment."
 141   `(progn (defmacro ,name ,args ,@body)
 142           (ps:import-macros-from-lisp ',name)))
 143
 144 (defmacro defmacro+ps (name args &body body)
 145   "Define a Lisp macro and a ParenScript macro in their respective
 146 macro environments. This function should be used when you want to use
 147 the same macro in both Lisp and ParenScript, but the 'macroexpand' of
 148 that macro in Lisp makes the Lisp macro unsuitable to be imported into
 149 the ParenScript macro environment."
 150   `(progn (defmacro ,name ,args ,@body)
 151           (defpsmacro ,name ,args ,@body)))
 152
 153 (defun ps-macroexpand (form)
 154   "Recursively macroexpands ParenScript macros and symbol-macros in
 155 the given ParenScript form. Returns two values: the expanded form, and
 156 whether any expansion was performed on the form or not."
 157   (if (consp form)
 158       (let ((op (car form))
 159             (args (cdr form)))
 160         (cond ((equal op 'quote)
 161                (values
 162                 (if (equalp '(nil) args) nil form) ;; leave quotes alone, unless it's a quoted nil
 163                 nil))
 164               ((script-macro-p op) ;; recursively expand parenscript macros in parent env.
 165                (multiple-value-bind (expansion-function macro-env)
 166                    (lookup-macro-expansion-function op)
 167                  (values
 168                   (ps-macroexpand (let ((*script-macro-env* macro-env))
 169                                         (apply expansion-function args)))
 170                   t)))
 171               (t (values form nil))))
 172       (cond ((script-symbol-macro-p form)
 173              ;; recursively expand symbol macros in parent env.
 174              (multiple-value-bind (expansion-function macro-env)
 175                  (lookup-macro-expansion-function form)
 176                (values
 177                 (ps-macroexpand (let ((*script-macro-env* macro-env))
 178                                       (funcall expansion-function)))
 179                 t)))
 180             ;; leave anything else alone
 181             (t (values form nil)))))
 182
 183 ;;;; compiler interface
 184 (defgeneric compile-parenscript-form (form &key expecting)
 185   (:documentation "Compiles a ParenScript form to the intermediate
 186 ParenScript representation. :expecting determines whether the form is
 187 compiled to an :expression (the default), a :statement, or a
 188 :symbol."))
 189
 190 (defmethod compile-parenscript-form :around (form &key expecting)
 191   (if (eql expecting :symbol)
 192       (compile-to-symbol form)
 193       (multiple-value-bind (expanded-form expanded-p)
 194           (ps-macroexpand form)
 195         (if expanded-p
 196             (compile-parenscript-form expanded-form :expecting expecting)
 197             (call-next-method)))))
 198
 199 (defun compile-to-symbol (form)
 200   "Compiles the given Parenscript form and guarantees that the
 201 resultant symbol has an associated script-package. Raises an error if
 202 the form cannot be compiled to a symbol."
 203   (let ((exp (compile-parenscript-form form)))
 204     (when (or (eql (first exp) 'js-variable)
 205               (eql (first exp) 'script-quote))
 206       (setf exp (second exp)))
 207     (assert (symbolp exp) ()
 208             "~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)
 209     exp))
 210
 211 (defmethod compile-parenscript-form (form &key expecting)
 212   (declare (ignore expecting))
 213   (error "The object ~S cannot be compiled by ParenScript." form))
 214
 215 (defmethod compile-parenscript-form ((form number) &key expecting)
 216   (declare (ignore expecting))
 217   form)
 218
 219 (defmethod compile-parenscript-form ((form string) &key expecting)
 220   (declare (ignore expecting))
 221   form)
 222
 223 (defmethod compile-parenscript-form ((form character) &key expecting)
 224   (declare (ignore expecting))
 225   (compile-parenscript-form (string form)))
 226
 227 (defmethod compile-parenscript-form ((symbol symbol) &key expecting)
 228   (declare (ignore expecting))
 229   ;; is this the correct behavior?
 230   (let ((special-symbol (get-ps-special-form symbol)))
 231     (cond (special-symbol (funcall special-symbol :symbol))
 232           ;; the following emulates the lisp behavior that a keyword is bound to itself
 233           ;; see http://clhs.lisp.se/Body/t_kwd.htm
 234           ((keywordp symbol) (compile-parenscript-form `(quote ,symbol)))
 235           (t (list 'js-variable symbol)))))
 236
 237 (defun compile-function-argument-forms (arg-forms)
 238   "Compiles a bunch of Parenscript forms from a funcall form to an effective set of
 239 Javascript arguments.  The only extra processing this does is makes :keyword arguments
 240 into a single options argument via CREATE."
 241   (flet ((keyword-arg (arg)
 242            "If the given compiled expression is supposed to be a keyword argument, returns
 243 the keyword for it."
 244            (when (and (listp arg) (eql (first arg) 'script-quote)) (second arg))))
 245     (let ((compiled-args (mapcar #'compile-parenscript-form arg-forms)))
 246       (do ((effective-expressions nil)
 247            (expressions-subl compiled-args))
 248           ((not expressions-subl) (reverse effective-expressions))
 249         (let ((arg-expr (first expressions-subl)))
 250           (if (keyword-arg arg-expr)
 251               (progn (when (oddp (length expressions-subl))
 252                        (error "Odd number of keyword arguments: ~A." arg-forms))
 253                      (push (list 'js-object (loop for (name val) on expressions-subl by #'cddr
 254                                                   collect (list name val)))
 255                            effective-expressions)
 256                      (setf expressions-subl nil))
 257               (progn (push arg-expr effective-expressions)
 258                      (setf expressions-subl (rest expressions-subl)))))))))
 259
 260 (defmethod compile-parenscript-form ((form cons) &key (expecting :statement))
 261   (let* ((name (car form))
 262          (args (cdr form)))
 263     (cond ((eql name 'quote)
 264            (assert (= 1 (length args)) () "Wrong number of arguments to quote: ~s" args)
 265            (list 'script-quote (first args)))
 266           ((ps-special-form-p form) (apply (get-ps-special-form name) (cons expecting args)))
 267           ((op-form-p form)
 268            (list 'operator
 269                  (script-convert-op-name (compile-parenscript-form (first form) :expecting :symbol))
 270                  (mapcar (lambda (form) (compile-parenscript-form form :expecting :expression)) (rest form))))
 271           ((method-call-p form)
 272            (list 'js-method-call
 273                  (compile-parenscript-form name :expecting :symbol)
 274                  (compile-parenscript-form (first args) :expecting :expression)
 275                  (compile-function-argument-forms (rest args))))
 276           ((funcall-form-p form)
 277            (list 'js-funcall
 278                  (compile-parenscript-form name :expecting :expression)
 279                  (compile-function-argument-forms args)))
 280           (t (error "Cannot compile ~S to a ParenScript form." form)))))
 281