src/compiler.lisp

   1 (in-package #:parenscript)
   2 (in-readtable :parenscript)
   3
   4 (defvar *version* 2.3 "Parenscript compiler version.")
   5
   6 (defparameter %compiling-reserved-forms-p% t
   7   "Used to issue warnings when replacing PS special operators or macros.")
   8
   9 (defvar *defined-operators* ()
  10   "Special operators and macros defined by Parenscript. Replace at your own risk!")
  11
  12 (defun defined-operator-override-check (name &rest body)
  13   (when (and (not %compiling-reserved-forms-p%) (member name *defined-operators*))
  14     (warn 'simple-style-warning
  15           :format-control "Redefining Parenscript operator/macro ~A"
  16           :format-arguments (list name)))
  17   `(progn ,(when %compiling-reserved-forms-p% `(pushnew ',name *defined-operators*))
  18           ,@body))
  19
  20 (defvar *reserved-symbol-names*
  21   (list "break" "case" "catch" "continue" "default" "delete" "do" "else"
  22         "finally" "for" "function" "if" "in" "instanceof" "new" "return"
  23         "switch" "this" "throw" "try" "typeof" "var" "void" "while" "with"
  24         "abstract" "boolean" "byte" "char" "class" "const" "debugger" "double"
  25         "enum" "export" "extends" "final" "float" "goto" "implements" "import"
  26         "int" "interface" "long" "native" "package" "private" "protected"
  27         "public" "short" "static" "super" "synchronized" "throws" "transient"
  28         "volatile" "{}" "true" "false" "null" "undefined"))
  29
  30 (defun reserved-symbol? (symbol)
  31   (find (string-downcase (string symbol)) *reserved-symbol-names* :test #'string=))
  32
  33 ;;; special forms
  34
  35 (defvar *special-expression-operators* (make-hash-table :test 'eq))
  36 (defvar *special-statement-operators* (make-hash-table :test 'eq))
  37
  38 ;; need to split special op definition into two parts - statement and expression
  39 (defmacro %define-special-operator (type name lambda-list &body body)
  40   (defined-operator-override-check name
  41       `(setf (gethash ',name ,type)
  42              (lambda (&rest whole)
  43                (destructuring-bind ,lambda-list whole
  44                  ,@body)))))
  45
  46 (defmacro define-expression-operator (name lambda-list &body body)
  47   `(%define-special-operator *special-expression-operators* ,name ,lambda-list ,@body))
  48
  49 (defmacro define-statement-operator (name lambda-list &body body)
  50   `(%define-special-operator *special-statement-operators* ,name ,lambda-list ,@body))
  51
  52 (defun special-form? (form)
  53   (and (consp form)
  54        (symbolp (car form))
  55        (or (gethash (car form) *special-expression-operators*) (gethash (car form) *special-statement-operators*))))
  56
  57 ;;; scoping and lexical environment
  58
  59 (defvar *enclosing-lexical-block-declarations* ()
  60   "This special variable is expected to be bound to a fresh list by
  61 special forms that introduce a new JavaScript lexical block (currently
  62 function definitions and lambdas). Enclosed special forms are expected
  63 to push variable declarations onto the list when the variables
  64 declaration cannot be made by the enclosed form for example, a
  65 x,y,z expression progn. It is then the responsibility of the
  66 enclosing special form to introduce the variable bindings in its
  67 lexical block.")
  68
  69 (defvar in-loop-scope? nil
  70   "Used for seeing when we're in loops, so that we can introduce
  71   proper scoping for lambdas closing over loop-bound
  72   variables (otherwise they all share the same binding).")
  73
  74 (defvar *loop-scope-lexicals*)
  75 (defvar *loop-scope-lexicals-captured*)
  76
  77 (defvar *function-block-names* ())
  78 (defvar *lexical-extent-return-tags* ())
  79 (defvar *dynamic-extent-return-tags* ())
  80 (defvar *tags-that-return-throws-to*)
  81
  82 (defvar *special-variables* ())
  83
  84 (defun special-variable? (sym)
  85   (member sym *special-variables*))
  86
  87 ;;; macros
  88 (defun make-macro-dictionary ()
  89   (make-hash-table :test 'eq))
  90
  91 (defvar *macro-toplevel* (make-macro-dictionary)
  92   "Toplevel macro environment dictionary.")
  93
  94 (defvar *macro-env* (list *macro-toplevel*)
  95   "Current macro environment.")
  96
  97 (defvar *symbol-macro-toplevel* (make-macro-dictionary))
  98
  99 (defvar *symbol-macro-env* (list *symbol-macro-toplevel*))
 100
 101 (defvar *local-function-names* ())
 102 ;; is a subset of
 103 (defvar *enclosing-lexicals* ())
 104
 105 (defvar *setf-expanders* (make-macro-dictionary)
 106   "Setf expander dictionary. Key is the symbol of the access
 107 function of the place, value is an expansion function that takes the
 108 arguments of the access functions as a first value and the form to be
 109 stored as the second value.")
 110
 111 (defun lookup-macro-def (name env)
 112   (loop for e in env thereis (gethash name e)))
 113
 114 (defun make-ps-macro-function (args body)
 115   (let* ((whole-var (when (eql '&whole (first args)) (second args)))
 116          (effective-lambda-list (if whole-var (cddr args) args))
 117          (whole-arg (or whole-var (gensym "ps-macro-form-arg-"))))
 118     `(lambda (,whole-arg)
 119        (destructuring-bind ,effective-lambda-list
 120            (cdr ,whole-arg)
 121          ,@body))))
 122
 123 (defmacro defpsmacro (name args &body body)
 124   (defined-operator-override-check name
 125       `(setf (gethash ',name *macro-toplevel*) ,(make-ps-macro-function args body))))
 126
 127 (defmacro define-ps-symbol-macro (symbol expansion)
 128   (defined-operator-override-check symbol
 129       `(setf (gethash ',symbol *symbol-macro-toplevel*) (lambda (form) (declare (ignore form)) ',expansion))))
 130
 131 (defun import-macros-from-lisp (&rest names)
 132   "Import the named Lisp macros into the Parenscript macro
 133 environment. When the imported macro is macroexpanded by Parenscript,
 134 it is first fully macroexpanded in the Lisp macro environment, and
 135 then that expansion is further expanded by Parenscript."
 136   (dolist (name names)
 137     (eval `(defpsmacro ,name (&rest args)
 138              (macroexpand `(,',name ,@args))))))
 139
 140 (defmacro defmacro+ps (name args &body body)
 141   "Define a Lisp macro and a Parenscript macro with the same macro
 142 function (ie - the same result from macroexpand-1), for cases when the
 143 two have different full macroexpansions (for example if the CL macro
 144 contains implementation-specific code when macroexpanded fully in the
 145 CL environment)."
 146   `(progn (defmacro ,name ,args ,@body)
 147           (defpsmacro ,name ,args ,@body)))
 148
 149 (defun ps-macroexpand-1 (form)
 150   (aif (or (and (symbolp form) (lookup-macro-def form *symbol-macro-env*))
 151            (and (consp form) (lookup-macro-def (car form) *macro-env*)))
 152        (values (ps-macroexpand (funcall it form)) t)
 153        form))
 154
 155 (defun ps-macroexpand (form)
 156   (multiple-value-bind (form1 expanded?) (ps-macroexpand-1 form)
 157     (if expanded?
 158         (values (ps-macroexpand form1) t)
 159         form1)))
 160
 161 ;;;; compiler interface
 162
 163 (defparameter *compilation-level* :toplevel
 164   "This value takes on the following values:
 165 :toplevel indicates that we are traversing toplevel forms.
 166 :inside-toplevel-form indicates that we are inside a call to ps-compile-*
 167 nil indicates we are no longer toplevel-related.")
 168
 169 (defun adjust-compilation-level (form level)
 170   "Given the current *compilation-level*, LEVEL, and the fully macroexpanded
 171 form, FORM, returns the new value for *compilation-level*."
 172   (cond ((or (and (consp form) (member (car form) '(progn locally macrolet symbol-macrolet)))
 173              (and (symbolp form) (eq :toplevel level)))
 174          level)
 175         ((eq :toplevel level)
 176          :inside-toplevel-form)))
 177
 178 (defvar compile-expression?)
 179
 180 (define-condition compile-expression-error (error)
 181   ((form :initarg :form :reader error-form))
 182   (:report (lambda (condition stream)
 183              (format stream "The Parenscript form ~A cannot be compiled into an expression." (error-form condition)))))
 184
 185 (defun compile-special-form (form)
 186   (apply (if compile-expression?
 187              (or (gethash (car form) *special-expression-operators*)
 188                  (error 'compile-expression-error :form form))
 189              (or (gethash (car form) *special-statement-operators*)
 190                  (gethash (car form) *special-expression-operators*)))
 191          (cdr form)))
 192
 193 (defun ps-compile (form)
 194   (typecase form
 195     ((or null number string character) form)
 196     ((or symbol list)
 197      (multiple-value-bind (expansion expanded?) (ps-macroexpand form)
 198        (if expanded?
 199            (ps-compile expansion)
 200            (if (symbolp form)
 201                form
 202                (let ((*compilation-level* (adjust-compilation-level form *compilation-level*)))
 203                  (if (special-form? form)
 204                      (compile-special-form form)
 205                      `(ps-js:funcall ,(if (symbolp (car form))
 206                                        (maybe-rename-local-function (car form))
 207                                        (compile-expression (car form)))
 208                                   ,@(mapcar #'compile-expression (cdr form)))))))))
 209     (vector (ps-compile `(quote ,(coerce form 'list))))))
 210
 211 (defun compile-statement (form)
 212   (let ((compile-expression? nil))
 213     (ps-compile form)))
 214
 215 (defun compile-expression (form)
 216   (let ((compile-expression? t))
 217     (ps-compile form)))
 218
 219 (defvar *ps-gensym-counter* 0)
 220
 221 (defun ps-gensym (&optional (prefix-or-counter "_JS"))
 222   (assert (or (stringp prefix-or-counter) (integerp prefix-or-counter)))
 223   (let ((prefix (if (stringp prefix-or-counter) prefix-or-counter "_JS"))
 224         (counter (if (integerp prefix-or-counter) prefix-or-counter (incf *ps-gensym-counter*))))
 225    (make-symbol (format nil "~A~:[~;_~]~A" prefix
 226                         (digit-char-p (char prefix (1- (length prefix))))
 227                         counter))))
 228
 229 (defmacro with-ps-gensyms (symbols &body body)
 230   "Each element of SYMBOLS is either a symbol or a list of (symbol
 231 gensym-prefix-string)."
 232   `(let* ,(mapcar (lambda (symbol)
 233                     (destructuring-bind (symbol &optional prefix)
 234                         (if (consp symbol)
 235                             symbol
 236                             (list symbol))
 237                       (if prefix
 238                           `(,symbol (ps-gensym ,(string prefix)))
 239                           `(,symbol (ps-gensym ,(string symbol))))))
 240                   symbols)
 241      ,@body))
 242
 243 (defmacro ps-once-only ((&rest vars) &body body)
 244   (let ((gensyms (mapcar (lambda (x) (ps-gensym (string x))) vars)))
 245     `(let ,(mapcar (lambda (g v) `(,g (ps-gensym ,(string v)))) gensyms vars)
 246        `(let* (,,@(mapcar (lambda (g v) ``(,,g ,,v)) gensyms vars))
 247           ,(let ,(mapcar (lambda (g v) `(,v ,g)) gensyms vars)
 248              ,@body)))))