compiler.lisp 13.8 KB
Newer Older
1
(in-package #:parenscript)
2
(in-readtable :parenscript)
Red Daly's avatar
Red Daly committed
3

4
5
(defvar *version* 2.3 "Parenscript compiler version.")

6
7
8
(defparameter %compiling-reserved-forms-p% t
  "Used to issue warnings when replacing PS special operators or macros.")

9
(defvar *defined-operators* ()
10
11
12
  "Special operators and macros defined by Parenscript. Replace at your own risk!")

(defun defined-operator-override-check (name &rest body)
13
  (when (and (not %compiling-reserved-forms-p%) (member name *defined-operators*))
14
15
16
    (warn 'simple-style-warning
          :format-control "Redefining Parenscript operator/macro ~A"
          :format-arguments (list name)))
17
  `(progn ,(when %compiling-reserved-forms-p% `(pushnew ',name *defined-operators*))
18
19
          ,@body))

20
(defvar *reserved-symbol-names*
21
22
23
24
25
26
27
  (list "break" "case" "catch" "continue" "default" "delete" "do" "else"
        "finally" "for" "function" "if" "in" "instanceof" "new" "return"
        "switch" "this" "throw" "try" "typeof" "var" "void" "while" "with"
        "abstract" "boolean" "byte" "char" "class" "const" "debugger" "double"
        "enum" "export" "extends" "final" "float" "goto" "implements" "import"
        "int" "interface" "long" "native" "package" "private" "protected"
        "public" "short" "static" "super" "synchronized" "throws" "transient"
Vladimir Sedach's avatar
Vladimir Sedach committed
28
        "volatile" "{}" "true" "false" "null" "undefined"))
29

30
31
32
(defvar *lambda-wrappable-statements* ;; break, return, continue not included
  '(throw switch for for-in while try block))

33
(defun reserved-symbol-p (symbol)
34
  (find (string-downcase (string symbol)) *reserved-symbol-names* :test #'string=))
35

36
;;; special forms
37

38
39
(defvar *special-expression-operators* (make-hash-table :test 'eq))
(defvar *special-statement-operators* (make-hash-table :test 'eq))
40

41
42
;; need to split special op definition into two parts - statement and expression
(defmacro %define-special-operator (type name lambda-list &body body)
43
44
45
46
47
  (defined-operator-override-check name
      `(setf (gethash ',name ,type)
             (lambda (&rest whole)
               (destructuring-bind ,lambda-list whole
                 ,@body)))))
Red Daly's avatar
Red Daly committed
48

49
(defmacro define-expression-operator (name lambda-list &body body)
50
51
  `(%define-special-operator *special-expression-operators*
       ,name ,lambda-list ,@body))
52
53

(defmacro define-statement-operator (name lambda-list &body body)
54
55
  `(%define-special-operator *special-statement-operators*
       ,name ,lambda-list ,@body))
56
57

(defun special-form? (form)
58
59
  (and (consp form)
       (symbolp (car form))
60
61
       (or (gethash (car form) *special-expression-operators*)
           (gethash (car form) *special-statement-operators*))))
62

63
;;; scoping and lexical environment
64

65
(defvar *vars-needing-to-be-declared* ()
66
67
68
69
  "This special variable is expected to be bound to a fresh list by
special forms that introduce a new JavaScript lexical block (currently
function definitions and lambdas). Enclosed special forms are expected
to push variable declarations onto the list when the variables
70
71
72
73
74
75
76
77
declaration cannot be made by the enclosed form (for example, a x,y,z
expression progn). It is then the responsibility of the enclosing
special form to introduce the variable declarations in its lexical
block.")

(defvar *used-up-names*)
(setf (documentation '*used-up-names* 'variable)
      "Names that have been already used for lexical bindings in the current function scope.")
78

79
80
81
(defvar in-case? nil
  "Bind to T when compiling CASE branches.")

82
83
84
85
(defvar in-loop-scope? nil
  "Used for seeing when we're in loops, so that we can introduce
  proper scoping for lambdas closing over loop-bound
  variables (otherwise they all share the same binding).")
86
87
(defvar *loop-return-var* nil
  "Variable which is used to return values from inside loop bodies.")
88
89
90
91
(defvar *loop-return-set-var* nil
  "Variable which is set by RETURN-FROM when it returns a value from inside
  a loop.  The value is the name of a PS variable which dynamically
  indicates if the return statement indeed has been invoked.")
92

93
(defvar *loop-scope-lexicals*)
94
95
(setf (documentation '*loop-scope-lexicals* 'variable)
      "Lexical variables introduced by a loop.")
96
(defvar *loop-scope-lexicals-captured*)
97
98
(setf (documentation '*loop-scope-lexicals-captured* 'variable)
      "Lexical variables introduced by a loop that are also captured by lambdas inside a loop.")
99

100
101
102
103
104
(defvar in-function-scope? nil
  "Lets the compiler know when lambda wrapping is necessary.")

(defvar *local-function-names* ()
  "Functions named by flet and label.")
Red Daly's avatar
Red Daly committed
105
;; is a subset of
106
107
108
109
110
111
112
113
114
115
116
(defvar *enclosing-lexicals* ()
  "All enclosing lexical variables (includes function names).")
(defvar *enclosing-function-arguments* ()
  "Lexical variables bound in all lexically enclosing function argument lists.")

(defvar *function-block-names* ()
  "All block names that this function is responsible for catching.")
(defvar *dynamic-return-tags* ()
  "Tags that need to be thrown to to reach.")
(defvar *current-block-tag* nil
  "Name of the lexically enclosing block, if any.")
117

118
119
(defvar *special-variables* ()
  "Special variables declared during any Parenscript run. Re-bind this if you want to clear the list.")
120

121
122
(defun special-variable? (sym)
  (member sym *special-variables*))
123

Red Daly's avatar
Red Daly committed
124
125
126
127
128
129
130
131
;;; meta info

(defvar *macro-toplevel-lambda-list* (make-hash-table)
  "Table of lambda lists for toplevel macros.")

(defvar *function-lambda-list* (make-hash-table)
  "Table of lambda lists for defined functions.")

132
133
134
;;; macros
(defun make-macro-dictionary ()
  (make-hash-table :test 'eq))
Daniel Gackle's avatar
Daniel Gackle committed
135

136
(defvar *macro-toplevel* (make-macro-dictionary)
137
  "Toplevel macro environment dictionary.")
138

139
(defvar *macro-env* (list *macro-toplevel*)
140
  "Current macro environment.")
Vladimir Sedach's avatar
Vladimir Sedach committed
141

142
(defvar *symbol-macro-toplevel* (make-macro-dictionary))
143

144
(defvar *symbol-macro-env* (list *symbol-macro-toplevel*))
145

146
(defvar *setf-expanders* (make-macro-dictionary)
147
  "Setf expander dictionary. Key is the symbol of the access
Vladimir Sedach's avatar
Vladimir Sedach committed
148
149
150
function of the place, value is an expansion function that takes the
arguments of the access functions as a first value and the form to be
stored as the second value.")
151

152
153
(defun lookup-macro-def (name env)
  (loop for e in env thereis (gethash name e)))
Red Daly's avatar
Red Daly committed
154

155
(defun make-ps-macro-function (args body)
Red Daly's avatar
Red Daly committed
156
157
158
159
  "Given the arguments and body to a parenscript macro, returns a
function that may be called on the entire parenscript form and outputs
some parenscript code.  Returns a second value that is the effective
lambda list from a Parenscript perspective."
160
161
162
  (let* ((whole-var (when (eql '&whole (first args)) (second args)))
         (effective-lambda-list (if whole-var (cddr args) args))
         (whole-arg (or whole-var (gensym "ps-macro-form-arg-"))))
Red Daly's avatar
Red Daly committed
163
164
165
166
167
168
    (values
     `(lambda (,whole-arg)
        (destructuring-bind ,effective-lambda-list
            (cdr ,whole-arg)
          ,@body))
     effective-lambda-list)))
169

170
(defmacro defpsmacro (name args &body body)
171
  (defined-operator-override-check name
Red Daly's avatar
Red Daly committed
172
173
      (multiple-value-bind (macro-fn-form effective-lambda-list)
          (make-ps-macro-function args body)
174
        `(eval-when (:compile-toplevel :load-toplevel :execute)
Red Daly's avatar
Red Daly committed
175
176
177
           (setf (gethash ',name *macro-toplevel*) ,macro-fn-form)
           (setf (gethash ',name *macro-toplevel-lambda-list*) ',effective-lambda-list)
           ',name))))
Red Daly's avatar
Red Daly committed
178

179
(defmacro define-ps-symbol-macro (symbol expansion)
180
  (defined-operator-override-check symbol
181
182
      `(eval-when (:compile-toplevel :load-toplevel :execute)
	 (setf (gethash ',symbol *symbol-macro-toplevel*) (lambda (form) (declare (ignore form)) ',expansion)))))
Red Daly's avatar
Red Daly committed
183

184
(defun import-macros-from-lisp (&rest names)
185
186
  "Import the named Lisp macros into the Parenscript macro
environment. When the imported macro is macroexpanded by Parenscript,
187
it is first fully macroexpanded in the Lisp macro environment, and
188
then that expansion is further expanded by Parenscript."
189
  (dolist (name names)
190
191
    (eval `(defpsmacro ,name (&rest args)
             (macroexpand `(,',name ,@args))))))
192

193
(defmacro defmacro+ps (name args &body body)
194
  "Define a Lisp macro and a Parenscript macro with the same macro
195
196
197
198
function (ie - the same result from macroexpand-1), for cases when the
two have different full macroexpansions (for example if the CL macro
contains implementation-specific code when macroexpanded fully in the
CL environment)."
199
  `(progn (defmacro ,name ,args ,@body)
200
201
          (defpsmacro ,name ,args ,@body)))

202
(defun ps-macroexpand-1 (form)
203
204
205
206
  (aif (or (and (symbolp form)
                (or (and (member form *enclosing-lexicals*)
                         (lookup-macro-def form *symbol-macro-env*))
                    (gethash form *symbol-macro-toplevel*))) ;; hack
207
           (and (consp form) (lookup-macro-def (car form) *macro-env*)))
208
209
210
       (values (ps-macroexpand (funcall it form)) t)
       form))

211
212
213
214
215
216
(defun ps-macroexpand (form)
  (multiple-value-bind (form1 expanded?) (ps-macroexpand-1 form)
    (if expanded?
        (values (ps-macroexpand form1) t)
        form1)))

217
218
;;; lambda wrapping

219
220
(defvar *ps-gensym-counter* 0)

221
222
223
224
225
226
227
228
229
230
(defvar this-in-lambda-wrapped-form? nil)

(defun lambda-wrap (form)
  (let ((this-in-lambda-wrapped-form? :query)
	(*ps-gensym-counter* *ps-gensym-counter*))
    (ps-compile form)
    (if (eq this-in-lambda-wrapped-form? :yes)
	`(chain (lambda () ,form) (call this))
	`((lambda () ,form)))))

231
;;;; compiler interface
232
233
234
235
236
237
238
239
240
241

(defparameter *compilation-level* :toplevel
  "This value takes on the following values:
:toplevel indicates that we are traversing toplevel forms.
:inside-toplevel-form indicates that we are inside a call to ps-compile-*
nil indicates we are no longer toplevel-related.")

(defun adjust-compilation-level (form level)
  "Given the current *compilation-level*, LEVEL, and the fully macroexpanded
form, FORM, returns the new value for *compilation-level*."
242
243
  (cond ((or (and (consp form)
                  (member (car form) '(progn locally macrolet symbol-macrolet)))
244
             (and (symbolp form) (eq :toplevel level)))
Vladimir Sedach's avatar
Vladimir Sedach committed
245
         level)
246
        ((eq :toplevel level) :inside-toplevel-form)))
Vladimir Sedach's avatar
Vladimir Sedach committed
247

248
249
250
251
252
253
254
255
(defvar compile-expression?)

(define-condition compile-expression-error (error)
  ((form :initarg :form :reader error-form))
  (:report (lambda (condition stream)
             (format stream "The Parenscript form ~A cannot be compiled into an expression." (error-form condition)))))

(defun compile-special-form (form)
256
257
258
  (let* ((op (car form))
         (statement-impl (gethash op *special-statement-operators*))
         (expression-impl (gethash op *special-expression-operators*)))
259
    (cond ((or (not compile-expression?) this-in-lambda-wrapped-form?)
260
261
262
263
           (apply (or statement-impl expression-impl) (cdr form)))
          (expression-impl
           (apply expression-impl (cdr form)))
          ((member op *lambda-wrappable-statements*)
264
           (compile-expression (lambda-wrap form)))
265
          (t (error 'compile-expression-error :form form)))))
266
267

(defun ps-compile (form)
268
269
270
271
  (macrolet ((try-expanding (form &body body)
               `(multiple-value-bind (expansion expanded?) (ps-macroexpand ,form)
                  (if expanded?
                      (ps-compile expansion)
272
                      (progn ,@body)))))
273
274
275
276
277
278
    (typecase form
      ((or null number string character)
       form)
      (vector
       (ps-compile `(quote ,(coerce form 'list))))
      (symbol
279
280
281
282
       (try-expanding form
	 (when (and (eq form 'this) (eq this-in-lambda-wrapped-form? :query))
	   (setq this-in-lambda-wrapped-form? :yes))
	 form))
283
284
285
286
287
288
289
290
291
292
293
      (cons
       (try-expanding form
         (let ((*compilation-level*
                (adjust-compilation-level form *compilation-level*)))
           (if (special-form? form)
               (compile-special-form form)
               `(ps-js:funcall
                 ,(if (symbolp (car form))
                      (maybe-rename-local-function (car form))
                      (compile-expression (car form)))
                 ,@(mapcar #'compile-expression (cdr form))))))))))
294

Vladimir Sedach's avatar
Vladimir Sedach committed
295
(defun compile-statement (form)
296
297
298
  (let ((compile-expression? nil))
    (ps-compile form)))

Vladimir Sedach's avatar
Vladimir Sedach committed
299
(defun compile-expression (form)
300
301
302
  (let ((compile-expression? t))
    (ps-compile form)))

303
304
305
306
307
308
309
(defun ps-gensym (&optional (prefix-or-counter "_JS"))
  (assert (or (stringp prefix-or-counter) (integerp prefix-or-counter)))
  (let ((prefix (if (stringp prefix-or-counter) prefix-or-counter "_JS"))
        (counter (if (integerp prefix-or-counter) prefix-or-counter (incf *ps-gensym-counter*))))
   (make-symbol (format nil "~A~:[~;_~]~A" prefix
                        (digit-char-p (char prefix (1- (length prefix))))
                        counter))))
310
311

(defmacro with-ps-gensyms (symbols &body body)
312
  "Each element of SYMBOLS is either a symbol or a list of (symbol
313
314
315
316
317
318
319
gensym-prefix-string)."
  `(let* ,(mapcar (lambda (symbol)
                    (destructuring-bind (symbol &optional prefix)
                        (if (consp symbol)
                            symbol
                            (list symbol))
                      (if prefix
320
321
                          `(,symbol (ps-gensym ,(string prefix)))
                          `(,symbol (ps-gensym ,(string symbol))))))
322
323
                  symbols)
     ,@body))
324
325
326
327
328
329
330

(defmacro ps-once-only ((&rest vars) &body body)
  (let ((gensyms (mapcar (lambda (x) (ps-gensym (string x))) vars)))
    `(let ,(mapcar (lambda (g v) `(,g (ps-gensym ,(string v)))) gensyms vars)
       `(let* (,,@(mapcar (lambda (g v) ``(,,g ,,v)) gensyms vars))
          ,(let ,(mapcar (lambda (g v) `(,v ,g)) gensyms vars)
             ,@body)))))
331
332
333
334
335
336
337
338
339
340
341
342
343
344

(defmacro maybe-once-only (vars &body body)
  "Introduces a binding for a form if the form is not a variable or
  constant. If it is, uses that form in the body directly."
  (let ((vars-bound (gensym)))
    `(let* ((,vars-bound ())
            ,@(loop for var in vars collect
                   `(,var (if (or (constantp ,var) (symbolp ,var))
                              ,var
                              (let ((gensym (ps-gensym ,(symbol-name var))))
                                (push `(,gensym ,,var) ,vars-bound)
                                gensym)))))
       `(let ,,vars-bound
         ,,@body))))