src/function-definition.lisp

   1 (in-package #:parenscript)
   2 (in-readtable :parenscript)
   3
   4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   5 ;;; lambda lists
   6
   7 (defun parse-key-spec (key-spec)
   8   "parses an &key parameter.  Returns 5 values:
   9 var, init-form,  keyword-name, supplied-p-var, init-form-supplied-p.
  10
  11 Syntax of key spec:
  12 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}*
  13 "
  14   (let* ((var (cond ((symbolp key-spec) key-spec)
  15                     ((and (listp key-spec) (symbolp (first key-spec))) (first key-spec))
  16                     ((and (listp key-spec) (listp (first key-spec)))   (second (first key-spec)))))
  17          (keyword-name (if (and (listp key-spec) (listp (first key-spec)))
  18                            (first (first key-spec))
  19                            (intern (string var) :keyword)))
  20          (init-form (if (listp key-spec) (second key-spec) nil))
  21          (init-form-supplied-p (if (listp key-spec) t nil))
  22          (supplied-p-var (if (listp key-spec) (third key-spec) nil)))
  23     (values var init-form keyword-name supplied-p-var init-form-supplied-p)))
  24
  25 (defun parse-optional-spec (spec)
  26   "Parses an &optional parameter.  Returns 3 values: var, init-form, supplied-p-var.
  27 [&optional {var | (var [init-form [supplied-p-parameter]])}*] "
  28   (let* ((var (cond ((symbolp spec) spec)
  29                     ((and (listp spec) (first spec)))))
  30          (init-form (if (listp spec) (second spec)))
  31          (supplied-p-var (if (listp spec) (third spec))))
  32     (values var init-form supplied-p-var)))
  33
  34 (defun parse-extended-function (lambda-list body)
  35   "The lambda list is transformed as follows:
  36
  37 * standard and optional variables are the mapped directly into
  38   the js-lambda list
  39
  40 * keyword variables are not included in the js-lambda list, but
  41   instead are obtained from the magic js ARGUMENTS
  42   pseudo-array. Code assigning values to keyword vars is
  43   prepended to the body of the function."
  44   (multiple-value-bind (requireds optionals rest? rest keys? keys allow? aux?
  45                                   aux more? more-context more-count key-object)
  46       (parse-lambda-list lambda-list)
  47     (declare (ignore allow? aux? aux more? more-context more-count key-object))
  48     (let* ( ;; optionals are of form (var default-value)
  49            (effective-args
  50             (remove-if #'null
  51                        (append requireds
  52                                (mapcar #'parse-optional-spec optionals))))
  53            (opt-forms
  54             (mapcar (lambda (opt-spec)
  55                       (multiple-value-bind (name value suppl)
  56                           (parse-optional-spec opt-spec)
  57                         (if suppl
  58                             `(progn
  59                                (var ,suppl (not (eql ,name undefined)))
  60                                ,@(when value
  61                                    `((when (not ,suppl) (setf ,name ,value)))))
  62                             (when value
  63                               `(when (eql ,name undefined)
  64                                  (setf ,name ,value))))))
  65                     optionals))
  66            (key-forms
  67             (when keys?
  68               (with-ps-gensyms (n)
  69                 (let (defaults assigns)
  70                   (mapc
  71                    (lambda (k)
  72                      (multiple-value-bind (var init-form keyword-str suppl)
  73                          (parse-key-spec k)
  74                        (push `(var ,var ,@(when init-form `((if (undefined ,var) ,init-form ,var)))) defaults)
  75                        (when suppl (push `(var ,suppl) defaults))
  76                        (push `(,keyword-str
  77                                (setf ,var (aref arguments (1+ ,n))
  78                                      ,@(when suppl `(,suppl t))))
  79                              assigns)))
  80                    (reverse keys))
  81                   `((loop for ,n from ,(length requireds) below (length arguments) by 2 do
  82                          (case (aref arguments ,n)
  83                            ,@assigns))
  84                     ,@defaults)))))
  85            (rest-form
  86             (when rest?
  87               (with-ps-gensyms (i)
  88                 `(progn (var ,rest (array))
  89                         (dotimes (,i (- (getprop arguments 'length)
  90                                         ,(length effective-args)))
  91                           (setf (aref ,rest
  92                                       ,i)
  93                                 (aref arguments
  94                                       (+ ,i ,(length effective-args)))))))))
  95            (docstring (and (cdr body) (stringp (car body)) (car body)))
  96            (effective-body (append opt-forms
  97                                    key-forms
  98                                    (awhen rest-form (list it))
  99                                    (if docstring (rest body) body))))
 100       (values effective-args effective-body docstring))))
 101
 102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 103 ;;; common
 104
 105 (defun collapse-function-return-blocks (body)
 106   (append (butlast body)
 107           (let ((last (ps-macroexpand (car (last body)))))
 108             (if (and (listp last) (eq 'block (car last)))
 109                 (progn (push (or (second last) 'nilBlock) *function-block-names*)
 110                        (cddr last))
 111                 (list last)))))
 112
 113 (defun compile-function-body (args body)
 114   (with-declaration-effects (body body)
 115     (let* ((*enclosing-lexical-block-declarations* ())
 116            (*enclosing-function-arguments*
 117             (append args *enclosing-function-arguments*))
 118            (*enclosing-lexicals*
 119             (set-difference *enclosing-lexicals* args))
 120            (collapsed-body (collapse-function-return-blocks body))
 121            (*dynamic-return-tags* (append (mapcar (lambda (x) (cons x nil))
 122                                                   *function-block-names*)
 123                                           *dynamic-return-tags*))
 124            (body
 125             (let ((in-loop-scope?                 nil)
 126                   (*loop-scope-lexicals*          ())
 127                   (*loop-scope-lexicals-captured* ()))
 128               (compile-statement
 129                `(return-from %function (progn ,@collapsed-body)))))
 130            (var-decls
 131             (compile-statement
 132              `(progn
 133                 ,@(mapcar
 134                    (lambda (var)
 135                      `(var ,var))
 136                    (remove-duplicates *enclosing-lexical-block-declarations*))))))
 137       (when in-loop-scope? ;; this is probably broken when it comes to let-renaming
 138         (setf *loop-scope-lexicals-captured*
 139               (append (intersection (flatten body) *loop-scope-lexicals*)
 140                       *loop-scope-lexicals-captured*)))
 141       `(ps-js:block ,@(cdr var-decls)
 142          ,@(cdr (wrap-for-dynamic-return *function-block-names* body))))))
 143
 144 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 145 ;;; lambda
 146
 147 (define-expression-operator lambda (lambda-list &rest body)
 148   (multiple-value-bind (effective-args effective-body)
 149       (parse-extended-function lambda-list body)
 150     `(ps-js:lambda ,effective-args
 151        ,(let ((*function-block-names* ()))
 152           (compile-function-body effective-args effective-body)))))
 153
 154 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 155 ;;; named functions
 156
 157 (defun compile-named-function-body (name lambda-list body)
 158   (let ((*enclosing-lexicals* (cons name *enclosing-lexicals*))
 159         (*function-block-names* (list name)))
 160     (multiple-value-bind (effective-args effective-body docstring)
 161         (parse-extended-function lambda-list body)
 162       (values effective-args
 163               (compile-function-body effective-args effective-body)
 164               docstring))))
 165
 166 (define-statement-operator defun% (name lambda-list &rest body)
 167   (multiple-value-bind (effective-args body-block docstring)
 168       (compile-named-function-body name lambda-list body)
 169     (list 'ps-js:defun name effective-args docstring body-block)))
 170
 171 (defun maybe-rename-local-function (fun-name)
 172   (or (getf *local-function-names* fun-name) fun-name))
 173
 174 (defun collect-function-names (fn-defs)
 175   (loop for (fn-name) in fn-defs
 176         collect fn-name
 177         collect (if (or (member fn-name *enclosing-lexicals*)
 178                         (lookup-macro-def fn-name *symbol-macro-env*))
 179                     (ps-gensym (string fn-name))
 180                     fn-name)))
 181
 182 (define-expression-operator flet (fn-defs &rest body)
 183   (let* ((fn-renames (collect-function-names fn-defs))
 184          ;; the function definitions need to be compiled with previous lexical bindings
 185          (fn-defs
 186           (loop for (fn-name . (args . body)) in fn-defs collect
 187                (progn (when compile-expression?
 188                         (push (getf fn-renames fn-name)
 189                               *enclosing-lexical-block-declarations*))
 190                       (list (if compile-expression? 'ps-js:= 'ps-js:var)
 191                             (getf fn-renames fn-name)
 192                             (multiple-value-bind (args1 body-block)
 193                                 (compile-named-function-body fn-name args body)
 194                               `(ps-js:lambda ,args1 ,body-block))))))
 195          ;; the flet body needs to be compiled with the extended lexical environment
 196          (*enclosing-lexicals*
 197           (append fn-renames *enclosing-lexicals*))
 198          (*loop-scope-lexicals*
 199           (when in-loop-scope? (append fn-renames *loop-scope-lexicals*)))
 200          (*local-function-names*
 201           (append fn-renames *local-function-names*)))
 202     `(,(if compile-expression? 'ps-js:|,| 'ps-js:block)
 203        ,@fn-defs
 204        ,@(compile-progn body))))
 205
 206 (define-expression-operator labels (fn-defs &rest body)
 207   (let* ((fn-renames              (collect-function-names fn-defs))
 208          (*local-function-names*  (append fn-renames *local-function-names*))
 209          (*enclosing-lexicals*    (append fn-renames *enclosing-lexicals*))
 210          (*loop-scope-lexicals*   (when in-loop-scope?
 211                                     (append fn-renames *loop-scope-lexicals*))))
 212     `(,(if compile-expression? 'ps-js:|,| 'ps-js:block)
 213        ,@(loop for (fn-name . (args . body)) in fn-defs collect
 214                     (progn (when compile-expression?
 215                              (push (getf *local-function-names* fn-name)
 216                                    *enclosing-lexical-block-declarations*))
 217                            (list (if compile-expression? 'ps-js:= 'ps-js:var)
 218                                  (getf *local-function-names* fn-name)
 219                                  (let ((*function-block-names* (list fn-name)))
 220                                    (compile-expression `(lambda ,args ,@body))))))
 221        ,@(compile-progn body))))
 222
 223 (define-expression-operator function (fn-name) ;; one of the things responsible for function namespace
 224   (ps-compile (maybe-rename-local-function fn-name)))