src/function-definition.lisp

   1 ;;;; -*- encoding:utf-8 -*-
   2
   3 ;;; Copyright 2011 Vladimir Sedach
   4 ;;; Copyright 2014-2015 Boris Smilga
   5 ;;; Copyright 2014 Max Rottenkolber
   6
   7 ;;; SPDX-License-Identifier: BSD-3-Clause
   8
   9 ;;; Redistribution and use in source and binary forms, with or
  10 ;;; without modification, are permitted provided that the following
  11 ;;; conditions are met:
  12
  13 ;;; 1. Redistributions of source code must retain the above copyright
  14 ;;; notice, this list of conditions and the following disclaimer.
  15
  16 ;;; 2. Redistributions in binary form must reproduce the above
  17 ;;; copyright notice, this list of conditions and the following
  18 ;;; disclaimer in the documentation and/or other materials provided
  19 ;;; with the distribution.
  20
  21 ;;; 3. Neither the name of the copyright holder nor the names of its
  22 ;;; contributors may be used to endorse or promote products derived
  23 ;;; from this software without specific prior written permission.
  24
  25 ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
  26 ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
  27 ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
  28 ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  29 ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
  30 ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
  31 ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
  32 ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  33 ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
  34 ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  35 ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  36 ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  37 ;;; POSSIBILITY OF SUCH DAMAGE.
  38
  39 (in-package #:parenscript)
  40 (named-readtables:in-readtable :parenscript)
  41
  42 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43 ;;; lambda lists
  44
  45 (defun parse-key-spec (key-spec)
  46   "parses an &key parameter.  Returns 5 values:
  47 var, init-form,  keyword-name, supplied-p-var, init-form-supplied-p.
  48
  49 Syntax of key spec:
  50 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}*
  51 "
  52   (let* ((var (cond ((symbolp key-spec) key-spec)
  53                     ((and (listp key-spec) (symbolp (first key-spec))) (first key-spec))
  54                     ((and (listp key-spec) (listp (first key-spec)))   (second (first key-spec)))))
  55          (keyword-name (if (and (listp key-spec) (listp (first key-spec)))
  56                            (first (first key-spec))
  57                            (intern (string var) :keyword)))
  58          (init-form (if (listp key-spec) (second key-spec) nil))
  59          (init-form-supplied-p (if (listp key-spec) t nil))
  60          (supplied-p-var (if (listp key-spec) (third key-spec) nil)))
  61     (values var init-form keyword-name supplied-p-var init-form-supplied-p)))
  62
  63 (defun parse-optional-spec (spec)
  64   "Parses an &optional parameter.  Returns 3 values: var, init-form, supplied-p-var.
  65 [&optional {var | (var [init-form [supplied-p-parameter]])}*] "
  66   (let* ((var (cond ((symbolp spec) spec)
  67                     ((and (listp spec) (first spec)))))
  68          (init-form (if (listp spec) (second spec)))
  69          (supplied-p-var (if (listp spec) (third spec))))
  70     (values var init-form supplied-p-var)))
  71
  72 (defun parse-body (body &key allow-docstring)
  73   "Parses a function or block body, which may or may not include a
  74 docstring.  Returns 2 or 3 values: a docstring (if allowed for), a list
  75 of (declare ...) forms, and the remaining body."
  76   (let (docstring declarations)
  77     (loop while
  78          (cond ((and (consp (car body)) (eq (caar body) 'declare))
  79                 (push (pop body) declarations))
  80                ((and allow-docstring (not docstring)
  81                      (stringp (car body)) (cdr body))
  82                 (setf docstring (pop body)))))
  83     (values body declarations docstring)))
  84
  85 (defun parse-extended-function (lambda-list body)
  86   "The lambda list is transformed as follows:
  87
  88 * standard and optional variables are the mapped directly into
  89   the js-lambda list
  90
  91 * keyword variables are not included in the js-lambda list, but
  92   instead are obtained from the magic js ARGUMENTS
  93   pseudo-array. Code assigning values to keyword vars is
  94   prepended to the body of the function."
  95   (multiple-value-bind (requireds optionals rest? rest keys? keys allow? aux?
  96                                   aux more? more-context more-count key-object)
  97       (parse-lambda-list lambda-list)
  98     (declare (ignore allow? aux? aux more? more-context more-count key-object))
  99     (let* ( ;; optionals are of form (var default-value)
 100            (effective-args
 101             (remove-if #'null
 102                        (append requireds
 103                                (mapcar #'parse-optional-spec optionals))))
 104            (opt-forms
 105             (mapcar (lambda (opt-spec)
 106                       (multiple-value-bind (name value suppl)
 107                           (parse-optional-spec opt-spec)
 108                         (cond (suppl
 109                                `(progn
 110                                   (var ,suppl (not (eql ,name undefined)))
 111                                   ,@(when value
 112                                           `((when (not ,suppl) (setf ,name ,value))))))
 113                               (value
 114                                `(when (eql ,name undefined)
 115                                   (setf ,name ,value))))))
 116                     optionals))
 117            (key-forms
 118             (when keys?
 119               (with-ps-gensyms (n)
 120                 (let (defaults assigns)
 121                   (mapc
 122                    (lambda (k)
 123                      (multiple-value-bind (var init-form keyword-str suppl)
 124                          (parse-key-spec k)
 125                        (push `(var ,var ,@(when init-form `((if (undefined ,var) ,init-form ,var)))) defaults)
 126                        (when suppl (push `(var ,suppl) defaults))
 127                        (push `(,keyword-str
 128                                (setf ,var (aref arguments (1+ ,n))
 129                                      ,@(when suppl `(,suppl t))))
 130                              assigns)))
 131                    (reverse keys))
 132                   `((loop for ,n from ,(length requireds) below (length arguments) by 2 do
 133                           (case (aref arguments ,n)
 134                             ,@assigns))
 135                     ,@defaults)))))
 136            (rest-form
 137             (when rest?
 138               `(var ,rest
 139                     ((@ Array prototype slice call)
 140                      arguments ,(length effective-args))))))
 141       (multiple-value-bind (fun-body declarations docstring)
 142           (parse-body body :allow-docstring t)
 143         (values effective-args
 144                 (append declarations
 145                         opt-forms key-forms (awhen rest-form (list it))
 146                         fun-body)
 147                 docstring)))))
 148
 149 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 150 ;;; common
 151
 152 (defun collapse-function-return-blocks (body)
 153   (append (butlast body)
 154           (let ((last (ps-macroexpand (car (last body)))))
 155             (if (and (listp last) (eq 'block (car last)))
 156                 ;; no need for a block at the end of a function body
 157                 (progn (push (or (second last) 'nilBlock)
 158                              *function-block-names*)
 159                        (cddr last))
 160                 (list last)))))
 161
 162 (defun compile-function-body (args body)
 163   (with-declaration-effects (body body)
 164     (let* ((in-function-scope?            t)
 165            (*current-block-tag*           nil)
 166            (*vars-needing-to-be-declared* ())
 167            (*used-up-names*               ())
 168            (returning-values?             nil)
 169            (clear-multiple-values?        nil)
 170            (*enclosing-function-arguments*
 171             (append args *enclosing-function-arguments*))
 172            (*enclosing-lexicals*
 173             (set-difference *enclosing-lexicals* args))
 174            (collapsed-body
 175             (collapse-function-return-blocks body))
 176            (*dynamic-return-tags*
 177             (append (mapcar (lambda (x) (cons x nil))
 178                             *function-block-names*)
 179                     *dynamic-return-tags*))
 180            (body
 181             (let ((in-loop-scope?                 nil)
 182                   (*loop-scope-lexicals*           ())
 183                   (*loop-scope-lexicals-captured*  ()))
 184               (cdr
 185                (wrap-for-dynamic-return
 186                 *function-block-names*
 187                 (compile-statement
 188                  `(return-from %function (progn ,@collapsed-body)))))))
 189            (var-decls
 190             (compile-statement
 191              `(progn
 192                 ,@(mapcar
 193                    (lambda (var) `(var ,var))
 194                    (remove-duplicates *vars-needing-to-be-declared*))))))
 195       (when in-loop-scope?
 196         (setf *loop-scope-lexicals-captured*
 197               (append (intersection (flatten body) *loop-scope-lexicals*)
 198                       *loop-scope-lexicals-captured*)))
 199       `(ps-js:block ,@(reverse (cdr var-decls))
 200          ,@body))))
 201
 202 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 203 ;;; lambda
 204
 205 (define-expression-operator lambda (lambda-list &rest body)
 206   (multiple-value-bind (effective-args effective-body)
 207       (parse-extended-function lambda-list body)
 208     `(ps-js:lambda ,effective-args
 209        ,(let ((*function-block-names* ()))
 210           (compile-function-body effective-args effective-body)))))
 211
 212 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 213 ;;; named functions
 214
 215 (defun compile-named-function-body (name lambda-list body)
 216   (let ((*enclosing-lexicals* (cons name *enclosing-lexicals*))
 217         (*function-block-names* (list name)))
 218     (multiple-value-bind (effective-args effective-body docstring)
 219         (parse-extended-function lambda-list body)
 220       (values effective-args
 221               (compile-function-body effective-args effective-body)
 222               docstring))))
 223
 224 (define-statement-operator defun% (name lambda-list &rest body)
 225   (multiple-value-bind (effective-args body-block docstring)
 226       (compile-named-function-body name lambda-list body)
 227     (list 'ps-js:defun name effective-args docstring body-block)))
 228
 229 (defun maybe-rename-local-function (fun-name)
 230   (or (getf *local-function-names* fun-name) fun-name))
 231
 232 (defun collect-function-names (fn-defs)
 233   (loop for (fn-name) in fn-defs
 234         collect fn-name
 235         collect (if (or (member fn-name *enclosing-lexicals*)
 236                         (lookup-macro-def fn-name *symbol-macro-env*))
 237                     (ps-gensym (string fn-name))
 238                     fn-name)))
 239
 240 (defun compile-named-local-function (name args body)
 241   (multiple-value-bind (args1 body-block)
 242       (compile-named-function-body name args body)
 243     `(ps-js:lambda ,args1 ,body-block)))
 244
 245 (defmacro local-functions (special-op &body bindings)
 246   `(if in-function-scope?
 247        (let* ((fn-renames (collect-function-names fn-defs))
 248               ,@bindings)
 249          `(,(if compile-expression? 'ps-js:|,| 'ps-js:block)
 250             ,@definitions
 251             ,@(compile-progn body)))
 252        (ps-compile (with-lambda-scope `(,',special-op ,fn-defs ,@body)))))
 253
 254 (defun compile-local-function-defs (fn-defs renames)
 255   (loop for (fn-name . (args . body)) in fn-defs collect
 256        (progn (when compile-expression?
 257                 (push (getf renames fn-name)
 258                       *vars-needing-to-be-declared*))
 259               (list (if compile-expression? 'ps-js:= 'ps-js:var)
 260                     (getf renames fn-name)
 261                     (compile-named-local-function fn-name args body)))))
 262
 263 (define-expression-operator flet (fn-defs &rest body)
 264   (local-functions flet
 265     ;; the function definitions need to be compiled with previous
 266     ;; lexical bindings
 267     (definitions (compile-local-function-defs fn-defs fn-renames))
 268     ;; the flet body needs to be compiled with the extended
 269     ;; lexical environment
 270     (*enclosing-lexicals*   (append fn-renames *enclosing-lexicals*))
 271     (*loop-scope-lexicals*  (when in-loop-scope?
 272                               (append fn-renames *loop-scope-lexicals*)))
 273     (*local-function-names* (append fn-renames *local-function-names*))))
 274
 275 (define-expression-operator labels (fn-defs &rest body)
 276   (local-functions labels
 277     (*enclosing-lexicals*   (append fn-renames *enclosing-lexicals*))
 278     (*loop-scope-lexicals*  (when in-loop-scope?
 279                               (append fn-renames *loop-scope-lexicals*)))
 280     (*local-function-names* (append fn-renames *local-function-names*))
 281     (definitions (compile-local-function-defs fn-defs *local-function-names*))))
 282
 283 (define-expression-operator function (fn-name)
 284   ;; one of the things responsible for function namespace
 285   (ps-compile (maybe-rename-local-function fn-name)))