compiler.lisp 15.9 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
;;; Copyright 2005 Manuel Odendahl
;;; Copyright 2005-2006 Edward Marco Baringer
;;; Copyright 2006 Attila Lendvai
;;; Copyright 2006 Luca Capello
;;; Copyright 2007-2012 Vladimir Sedach
;;; Copyright 2008 Travis Cross
;;; Copyright 2009-2010 Red Daly
;;; Copyright 2009-2010 Daniel Gackle

;;; SPDX-License-Identifier: BSD-3-Clause

;;; Redistribution and use in source and binary forms, with or
;;; without modification, are permitted provided that the following
;;; conditions are met:

;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.

;;; 2. Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials provided
;;; with the distribution.

;;; 3. Neither the name of the copyright holder nor the names of its
;;; contributors may be used to endorse or promote products derived
;;; from this software without specific prior written permission.

;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;; POSSIBILITY OF SUCH DAMAGE.
41

42
(in-package #:parenscript)
43
(in-readtable :parenscript)
Red Daly's avatar
Red Daly committed
44

45
(defvar *version* 2.7 "Parenscript compiler version.")
46

47
48
49
(defparameter %compiling-reserved-forms-p% t
  "Used to issue warnings when replacing PS special operators or macros.")

50
(defvar *defined-operators* ()
51
52
53
  "Special operators and macros defined by Parenscript. Replace at your own risk!")

(defun defined-operator-override-check (name &rest body)
54
  (when (and (not %compiling-reserved-forms-p%) (member name *defined-operators*))
55
56
57
    (warn 'simple-style-warning
          :format-control "Redefining Parenscript operator/macro ~A"
          :format-arguments (list name)))
58
  `(progn ,(when %compiling-reserved-forms-p% `(pushnew ',name *defined-operators*))
59
60
          ,@body))

61
(defvar *reserved-symbol-names*
62
63
64
65
66
67
68
  (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
69
        "volatile" "{}" "true" "false" "null" "undefined"))
70

71
72
73
(defvar *lambda-wrappable-statements* ;; break, return, continue not included
  '(throw switch for for-in while try block))

74
(defun reserved-symbol-p (symbol)
75
  (find (string-downcase (string symbol)) *reserved-symbol-names* :test #'string=))
76

77
;;; special forms
78

79
80
(defvar *special-expression-operators* (make-hash-table :test 'eq))
(defvar *special-statement-operators* (make-hash-table :test 'eq))
81

82
83
;; need to split special op definition into two parts - statement and expression
(defmacro %define-special-operator (type name lambda-list &body body)
84
85
86
87
88
  (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
89

90
(defmacro define-expression-operator (name lambda-list &body body)
91
92
  `(%define-special-operator *special-expression-operators*
       ,name ,lambda-list ,@body))
93
94

(defmacro define-statement-operator (name lambda-list &body body)
95
96
  `(%define-special-operator *special-statement-operators*
       ,name ,lambda-list ,@body))
97
98

(defun special-form? (form)
99
100
  (and (consp form)
       (symbolp (car form))
101
102
       (or (gethash (car form) *special-expression-operators*)
           (gethash (car form) *special-statement-operators*))))
103

104
;;; scoping and lexical environment
105

106
(defvar *vars-needing-to-be-declared* ()
107
108
109
110
  "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
111
112
113
114
115
116
117
118
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.")
119

120
121
122
(defvar in-case? nil
  "Bind to T when compiling CASE branches.")

123
124
125
126
(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).")
127
128
(defvar *loop-return-var* nil
  "Variable which is used to return values from inside loop bodies.")
129
130
131
132
(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.")
133

134
(defvar *loop-scope-lexicals*)
135
136
(setf (documentation '*loop-scope-lexicals* 'variable)
      "Lexical variables introduced by a loop.")
137
(defvar *loop-scope-lexicals-captured*)
138
139
(setf (documentation '*loop-scope-lexicals-captured* 'variable)
      "Lexical variables introduced by a loop that are also captured by lambdas inside a loop.")
140

141
142
143
144
145
(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
146
;; is a subset of
147
148
149
150
151
152
153
154
155
156
157
(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.")
158

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

162
163
(defun special-variable? (sym)
  (member sym *special-variables*))
164

Red Daly's avatar
Red Daly committed
165
166
167
168
169
170
171
172
;;; 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.")

173
174
175
;;; macros
(defun make-macro-dictionary ()
  (make-hash-table :test 'eq))
Daniel Gackle's avatar
Daniel Gackle committed
176

177
(defvar *macro-toplevel* (make-macro-dictionary)
178
  "Toplevel macro environment dictionary.")
179

180
(defvar *macro-env* (list *macro-toplevel*)
181
  "Current macro environment.")
Vladimir Sedach's avatar
Vladimir Sedach committed
182

183
(defvar *symbol-macro-toplevel* (make-macro-dictionary))
184

185
(defvar *symbol-macro-env* (list *symbol-macro-toplevel*))
186

187
(defvar *setf-expanders* (make-macro-dictionary)
188
  "Setf expander dictionary. Key is the symbol of the access
Vladimir Sedach's avatar
Vladimir Sedach committed
189
190
191
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.")
192

193
194
(defun lookup-macro-def (name env)
  (loop for e in env thereis (gethash name e)))
Red Daly's avatar
Red Daly committed
195

196
(defun make-ps-macro-function (args body)
Red Daly's avatar
Red Daly committed
197
198
199
200
  "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."
201
202
203
  (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
204
205
206
207
208
209
    (values
     `(lambda (,whole-arg)
        (destructuring-bind ,effective-lambda-list
            (cdr ,whole-arg)
          ,@body))
     effective-lambda-list)))
210

211
(defmacro defpsmacro (name args &body body)
212
  (defined-operator-override-check name
Red Daly's avatar
Red Daly committed
213
214
      (multiple-value-bind (macro-fn-form effective-lambda-list)
          (make-ps-macro-function args body)
215
        `(eval-when (:compile-toplevel :load-toplevel :execute)
Red Daly's avatar
Red Daly committed
216
217
218
           (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
219

220
(defmacro define-ps-symbol-macro (symbol expansion)
221
  (defined-operator-override-check symbol
222
223
      `(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
224

225
(defun import-macros-from-lisp (&rest names)
226
227
  "Import the named Lisp macros into the Parenscript macro
environment. When the imported macro is macroexpanded by Parenscript,
228
it is first fully macroexpanded in the Lisp macro environment, and
229
then that expansion is further expanded by Parenscript."
230
  (dolist (name names)
231
232
    (eval `(defpsmacro ,name (&rest args)
             (macroexpand `(,',name ,@args))))))
233

234
(defmacro defmacro+ps (name args &body body)
235
  "Define a Lisp macro and a Parenscript macro with the same macro
236
237
238
239
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)."
240
  `(progn (defmacro ,name ,args ,@body)
241
242
          (defpsmacro ,name ,args ,@body)))

243
(defun ps-macroexpand-1 (form)
244
245
246
247
  (aif (or (and (symbolp form)
                (or (and (member form *enclosing-lexicals*)
                         (lookup-macro-def form *symbol-macro-env*))
                    (gethash form *symbol-macro-toplevel*))) ;; hack
248
           (and (consp form) (lookup-macro-def (car form) *macro-env*)))
249
250
251
       (values (ps-macroexpand (funcall it form)) t)
       form))

252
253
254
255
256
257
(defun ps-macroexpand (form)
  (multiple-value-bind (form1 expanded?) (ps-macroexpand-1 form)
    (if expanded?
        (values (ps-macroexpand form1) t)
        form1)))

258
259
;;; lambda wrapping

260
261
(defvar *ps-gensym-counter* 0)

262
263
264
265
266
267
268
269
270
271
(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)))))

272
;;;; compiler interface
273
274
275
276
277
278
279
280
281
282

(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*."
283
284
  (cond ((or (and (consp form)
                  (member (car form) '(progn locally macrolet symbol-macrolet)))
285
             (and (symbolp form) (eq :toplevel level)))
Vladimir Sedach's avatar
Vladimir Sedach committed
286
         level)
287
        ((eq :toplevel level) :inside-toplevel-form)))
Vladimir Sedach's avatar
Vladimir Sedach committed
288

289
290
291
292
293
294
295
296
(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)
297
298
299
  (let* ((op (car form))
         (statement-impl (gethash op *special-statement-operators*))
         (expression-impl (gethash op *special-expression-operators*)))
300
    (cond ((or (not compile-expression?) this-in-lambda-wrapped-form?)
301
302
303
304
           (apply (or statement-impl expression-impl) (cdr form)))
          (expression-impl
           (apply expression-impl (cdr form)))
          ((member op *lambda-wrappable-statements*)
305
           (compile-expression (lambda-wrap form)))
306
          (t (error 'compile-expression-error :form form)))))
307
308

(defun ps-compile (form)
309
310
311
312
  (macrolet ((try-expanding (form &body body)
               `(multiple-value-bind (expansion expanded?) (ps-macroexpand ,form)
                  (if expanded?
                      (ps-compile expansion)
313
                      (progn ,@body)))))
314
315
316
317
318
319
    (typecase form
      ((or null number string character)
       form)
      (vector
       (ps-compile `(quote ,(coerce form 'list))))
      (symbol
320
321
322
323
       (try-expanding form
	 (when (and (eq form 'this) (eq this-in-lambda-wrapped-form? :query))
	   (setq this-in-lambda-wrapped-form? :yes))
	 form))
324
325
326
327
328
329
330
331
332
333
334
      (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))))))))))
335

Vladimir Sedach's avatar
Vladimir Sedach committed
336
(defun compile-statement (form)
337
338
339
  (let ((compile-expression? nil))
    (ps-compile form)))

Vladimir Sedach's avatar
Vladimir Sedach committed
340
(defun compile-expression (form)
341
342
343
  (let ((compile-expression? t))
    (ps-compile form)))

344
345
346
347
348
349
350
351
352
(defun ps-gensym (&optional (x '_js))
  (make-symbol
   (if (integerp x)
       (format nil "~A~A" '_js x)
       (let ((prefix (string x)))
         (format nil "~A~:[~;_~]~A"
                 prefix
                 (digit-char-p (char prefix (1- (length prefix))))
                 (incf *ps-gensym-counter*))))))
353
354

(defmacro with-ps-gensyms (symbols &body body)
355
356
  "Helper macro for writing Parenscript macros. Each element of
SYMBOLS is either a symbol or a list of (symbol
357
358
359
360
361
362
363
gensym-prefix-string)."
  `(let* ,(mapcar (lambda (symbol)
                    (destructuring-bind (symbol &optional prefix)
                        (if (consp symbol)
                            symbol
                            (list symbol))
                      (if prefix
364
365
                          `(,symbol (ps-gensym ,(string prefix)))
                          `(,symbol (ps-gensym ,(string symbol))))))
366
367
                  symbols)
     ,@body))
368
369

(defmacro ps-once-only ((&rest vars) &body body)
370
  "Helper macro for writing Parenscript macros. Useful for preventing unwanted multiple evaluation."
371
372
373
374
375
376
377
  (let ((gensyms (mapcar #'ps-gensym vars)))
    `(let ,(mapcar (lambda (g v) `(,g (ps-gensym ',v)))
                   gensyms vars)
       `(let* (,,@(mapcar (lambda (g v) `(list ,g ,v))
                          gensyms vars))
          ,(let ,(mapcar (lambda (g v) (list v g))
                         gensyms vars)
378
             ,@body)))))
379

380
381
382
(defmacro maybe-once-only ((&rest vars) &body body)
  "Helper macro for writing Parenscript macros. Like PS-ONCE-ONLY,
except that if the given VARS are variables or constants, no intermediate variables are created."
383
  (let ((vars-bound (gensym)))
384
385
386
387
388
389
390
391
392
393
394
395
396
397
    `(let*
         ((,vars-bound ())
          ,@(loop for var in vars collect
                 `(,var
                   (if (or
                        (constantp ,var)
                        (and
                         (symbolp ,var)
                         (not (lookup-macro-def ,var *symbol-macro-env*))
                         (not (gethash ,var *symbol-macro-toplevel*))))
                        ,var
                        (let ((var¹ (ps-gensym ',var)))
                          (push (list var¹ ,var) ,vars-bound)
                          var¹)))))
398
       `(let ,,vars-bound
399
          ,,@body))))