src/macros.lisp

   1 ;;;; -*- encoding:utf-8 -*-
   2
   3 ;;; Copyright 2005 Manuel Odendahl
   4 ;;; Copyright 2005-2006 Edward Marco Baringer
   5 ;;; Copyright 2006 Luca Capello
   6 ;;; Copyright 2010-2012 Vladimir Sedach
   7 ;;; Copyright 2010-2013 Daniel Gackle
   8 ;;; Copyright 2012, 2014 Boris Smilga
   9
  10 ;;; SPDX-License-Identifier: BSD-3-Clause
  11
  12 ;;; Redistribution and use in source and binary forms, with or
  13 ;;; without modification, are permitted provided that the following
  14 ;;; conditions are met:
  15
  16 ;;; 1. Redistributions of source code must retain the above copyright
  17 ;;; notice, this list of conditions and the following disclaimer.
  18
  19 ;;; 2. Redistributions in binary form must reproduce the above
  20 ;;; copyright notice, this list of conditions and the following
  21 ;;; disclaimer in the documentation and/or other materials provided
  22 ;;; with the distribution.
  23
  24 ;;; 3. Neither the name of the copyright holder nor the names of its
  25 ;;; contributors may be used to endorse or promote products derived
  26 ;;; from this software without specific prior written permission.
  27
  28 ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
  29 ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
  30 ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
  31 ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  32 ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
  33 ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
  34 ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
  35 ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  36 ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
  37 ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  38 ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  39 ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  40 ;;; POSSIBILITY OF SUCH DAMAGE.
  41
  42 (in-package #:parenscript)
  43 (named-readtables:in-readtable :parenscript)
  44
  45 (macrolet ((define-trivial-mappings (&rest mappings)
  46              `(progn
  47                 ,@(loop for (macro-name ps-op) on mappings by #'cddr collect
  48                        `(defpsmacro ,macro-name (&rest args)
  49                           (cons ',ps-op args))))))
  50   (define-trivial-mappings
  51     string= eql
  52     eq      eql
  53     =       eql
  54     list    array
  55     elt     aref))
  56
  57 (defpsmacro null (x)
  58   `(equal ,x nil))
  59
  60 ;;; Math
  61
  62 (defmacro def-js-maths (&rest mathdefs)
  63   `(progn ,@(mapcar (lambda (def) (cons 'defpsmacro def)) mathdefs)))
  64
  65 (def-js-maths
  66     (max (&rest nums) `((@ *math max) ,@nums))
  67     (min (&rest nums) `((@ *math min) ,@nums))
  68     (floor (n &optional divisor)
  69       `((@ *math floor) ,(if divisor `(/ ,n ,divisor) n)))
  70     (ceiling (n &optional divisor)
  71       `((@ *math ceil) ,(if divisor `(/ ,n ,divisor) n)))
  72     (round (n &optional divisor)
  73       `((@ *math round) ,(if divisor `(/ ,n ,divisor) n)))
  74     (sin (n) `((@ *math sin) ,n))
  75     (cos (n) `((@ *math cos) ,n))
  76     (tan (n) `((@ *math tan) ,n))
  77     (asin (n) `((@ *math asin) ,n))
  78     (acos (n) `((@ *math acos) ,n))
  79     (atan (y &optional x) (if x `((@ *math atan2) ,y ,x) `((@ *math atan) ,y)))
  80     (sinh (x)
  81       (maybe-once-only (x)
  82         `(/ (- (exp ,x) (exp (- ,x))) 2)))
  83     (cosh (x)
  84       (maybe-once-only (x)
  85         `(/ (+ (exp ,x) (exp (- ,x))) 2)))
  86     (tanh (x)
  87       (maybe-once-only (x)
  88         `(/ (- (exp ,x) (exp (- ,x))) (+ (exp ,x) (exp (- ,x))))))
  89     (asinh (x)
  90       (maybe-once-only (x)
  91         `(log (+ ,x (sqrt (1+ (* ,x ,x)))))))
  92     (acosh (x)
  93       (maybe-once-only (x)
  94         `(* 2 (log (+ (sqrt (/ (1+ ,x) 2)) (sqrt (/ (1- ,x) 2)))))))
  95     (atanh (x) ;; real only for -1 < x < 1, otherwise complex
  96       (maybe-once-only (x)
  97         `(/ (- (log (+ 1 ,x)) (log (- 1 ,x))) 2)))
  98     (mod (x n)
  99       (maybe-once-only (n)
 100         `(rem (+ (rem ,x ,n) ,n) ,n)))
 101     (1+ (n) `(+ ,n 1))
 102     (1- (n) `(- ,n 1))
 103     (abs (n) `((@ *math abs) ,n))
 104     (evenp (n) `(not (oddp ,n)))
 105     (oddp (n) `(rem ,n 2))
 106     (exp (n) `((@ *math exp) ,n))
 107     (expt (base power) `((@ *math pow) ,base ,power))
 108     (log (n &optional base)
 109       (or (and (null base) `((@ *math log) ,n))
 110           (and (numberp base) (= base 10) `(* (log ,n) (@ *math *log10e*)))
 111           `(/ (log ,n) (log ,base))))
 112     (sqrt (n) `((@ *math sqrt) ,n))
 113     (random (&optional upto) (if upto
 114                                  (maybe-once-only (upto)
 115                                    `(if (rem ,upto 1)
 116                                         (* ,upto (random))
 117                                         (floor (* ,upto (random)))))
 118                                  '(funcall (@ *math random)))))
 119
 120 (defpsmacro ash (integer count)
 121   (let ((count (ps-macroexpand count)))
 122     (cond ((and (numberp count) (> count 0)) `(<< ,integer ,count))
 123           ((numberp count) `(>> ,integer ,(- count)))
 124           ((complex-js-expr? count)
 125            (let ((count-var (ps-gensym)))
 126              `(let ((,count-var ,count))
 127                 (if (> ,count-var 0)
 128                     (<< ,integer ,count-var)
 129                     (>> ,integer (- ,count-var))))))
 130           (t `(if (> ,count 0)
 131                   (<< ,integer ,count)
 132                   (>> ,integer (- ,count)))))))
 133
 134 (define-ps-symbol-macro pi (getprop *math '*pi*))
 135
 136 ;;; Types
 137
 138 (defpsmacro stringp (x)
 139   `(string= (typeof ,x) "string"))
 140
 141 (defpsmacro numberp (x)
 142   `(string= (typeof ,x) "number"))
 143
 144 (defpsmacro functionp (x)
 145   `(string= (typeof ,x) "function"))
 146
 147 (defpsmacro booleanp (x)
 148   `(string= (typeof ,x) "boolean"))
 149
 150 (defpsmacro listp (x)
 151   (if (js-target-at-least "1.8.5")
 152       `(funcall (getprop Array 'is-array) ,x)
 153       `(string= (funcall (getprop Object 'prototype 'to-string 'call) ,x)
 154                 "[object Array]")))
 155
 156 (defpsmacro arrayp (x)
 157   `(listp ,x))
 158
 159 ;;; Data structures
 160
 161 (defpsmacro make-array (&rest args)
 162   (or (ignore-errors
 163         (destructuring-bind (dim &key (initial-element nil initial-element-p)
 164                                  initial-contents element-type)
 165             args
 166           (declare (ignore element-type))
 167           (and (or initial-element-p initial-contents)
 168                (not (and initial-element-p initial-contents))
 169                (with-ps-gensyms (arr init elt i)
 170                  `(let ((,arr (new (*array ,dim))))
 171                     ,@(when initial-element-p
 172                         `((let ((,elt ,initial-element))
 173                             (dotimes (,i (length ,arr))
 174                               (setf (aref ,arr ,i) ,elt)))))
 175                     ,@(when initial-contents
 176                         `((let ((,init ,initial-contents))
 177                             (dotimes (,i (min (length ,arr) (length ,init)))
 178                               (setf (aref ,arr ,i) (aref ,init ,i))))))
 179                     ,arr)))))
 180       `(new (*array ,@args))))
 181
 182 (defpsmacro length (a)
 183   `(getprop ,a 'length))
 184
 185 ;;; Getters
 186
 187 (defpsmacro with-slots (slots object &rest body)
 188   (flet ((slot-var (slot)
 189            (if (listp slot)
 190                (first slot)
 191                slot))
 192          (slot-symbol (slot)
 193            (if (listp slot)
 194                (second slot)
 195                slot)))
 196     (maybe-once-only (object)
 197       `(symbol-macrolet ,(mapcar (lambda (slot)
 198                                    `(,(slot-var slot) (getprop ,object ',(slot-symbol slot))))
 199                                  slots)
 200          ,@body))))
 201
 202 ;;; multiple values
 203
 204 (defpsmacro multiple-value-bind (vars form &body body)
 205   (let* ((form       (ps-macroexpand form))
 206          (progn-form (when (and (consp form)
 207                                 (member (car form)
 208                                         '(with label let flet labels
 209                                           macrolet symbol-macrolet progn)))
 210                        (pop form))))
 211     (if progn-form
 212         `(,progn-form
 213           ,@(butlast form)
 214           (multiple-value-bind ,vars
 215               ,@(last form)
 216             ,@body))
 217         ;; assume function call
 218         `(progn
 219            (setf __PS_MV_REG '())
 220            (let ((,(car vars) ,form))
 221              (destructuring-bind (&optional ,@(cdr vars))
 222                  __PS_MV_REG
 223                ,@body))))))
 224
 225 (defpsmacro multiple-value-list (form)
 226   (with-ps-gensyms (first-value values-list)
 227     `(let* ((,first-value (progn
 228                             (setf __PS_MV_REG '())
 229                             ,form))
 230             (,values-list (funcall (getprop __PS_MV_REG 'slice))))
 231        (funcall (getprop ,values-list 'unshift) ,first-value)
 232        ,values-list)))
 233
 234 ;;; conditionals
 235
 236 (defpsmacro case (value &rest clauses)
 237   (labels
 238       ((make-switch-clause (val body more)
 239          (if (consp val)
 240              (append (mapcar #'list (butlast val))
 241                      (make-switch-clause
 242                       (if (eq t (car (last val))) ;; literal 'true'
 243                           '%true
 244                           (car (last val)))
 245                       body
 246                       more))
 247              `((,(cond ((member val '(t otherwise)) 'default)
 248                        ((eql val '%true)            t)
 249                        ((eql val 'false)            'false)
 250                        ((null val)                  'false)
 251                        ((symbolp val)               (list 'quote val))
 252                        (t                           val))
 253                  ,@body
 254                  ,@(when more '(break)))))))
 255     `(switch ,value
 256        ,@(mapcon (lambda (clause)
 257                    (make-switch-clause (car (first clause))
 258                                        (cdr (first clause))
 259                                        (rest clause)))
 260                  clauses))))
 261
 262 (defpsmacro when (test &rest body)
 263   `(if ,test (progn ,@body)))
 264
 265 (defpsmacro unless (test &rest body)
 266   `(when (not ,test) ,@body))
 267
 268 ;;; function definition
 269
 270 (defpsmacro defun (name lambda-list &body body)
 271   "An extended defun macro that allows cool things like keyword arguments.
 272 lambda-list::=
 273  (var*
 274   [&optional {var | (var [init-form [supplied-p-parameter]])}*]
 275   [&rest var]
 276   [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
 277   [&aux {var | (var [init-form])}*])"
 278   (if (symbolp name)
 279       (progn (setf (gethash name *function-lambda-list*) lambda-list)
 280              `(defun% ,name ,lambda-list ,@body))
 281       (progn (assert (and (listp name) (= (length name) 2) (eq 'setf (car name))) ()
 282                      "(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list)
 283              `(defun-setf ,(second name) ,lambda-list ,@body))))
 284
 285 ;;; defining setf expanders
 286
 287 (defvar *defun-setf-name-prefix* '__setf_)
 288
 289 (defpsmacro defun-setf (name lambda-list &body body)
 290   (let ((mangled-function-name
 291          (intern (format nil "~A~A" (string *defun-setf-name-prefix*) (string name))
 292                  (symbol-package name))))
 293     (setf (gethash name *setf-expanders*)
 294           (lambda (access-args store-form)
 295             `(,mangled-function-name ,store-form ,@access-args)))
 296     `(defun ,mangled-function-name ,lambda-list ,@body)))
 297
 298 ;;; slightly broken WRT lambda lists
 299 (defpsmacro defsetf-long (access-fn lambda-list (store-var) form)
 300   (setf (gethash access-fn *setf-expanders*)
 301         (compile
 302          nil
 303          (let ((var-bindings (ordered-set-difference lambda-list
 304                                                      lambda-list-keywords)))
 305            `(lambda (access-fn-args store-form)
 306               (destructuring-bind ,lambda-list
 307                   access-fn-args
 308                 (let* ((,store-var (ps-gensym))
 309                        (gensymed-names (loop repeat ,(length var-bindings)
 310                                           collecting (ps-gensym)))
 311                        (gensymed-arg-bindings (mapcar #'list
 312                                                       gensymed-names
 313                                                       (list ,@var-bindings))))
 314                   (destructuring-bind ,var-bindings
 315                       gensymed-names
 316                     `(let* (,@gensymed-arg-bindings
 317                             (,,store-var ,store-form))
 318                        ,,form))))))))
 319   nil)
 320
 321 (defpsmacro defsetf-short (access-fn update-fn &optional docstring)
 322   (declare (ignore docstring))
 323   (setf (gethash access-fn *setf-expanders*)
 324         (lambda (access-fn-args store-form)
 325           `(,update-fn ,@access-fn-args ,store-form)))
 326   nil)
 327
 328 (defpsmacro defsetf (access-fn &rest args)
 329   `(,(if (= (length args) 3) 'defsetf-long 'defsetf-short) ,access-fn ,@args))
 330
 331 ;;; setf
 332
 333 (defpsmacro setf (&rest args)
 334   (assert (evenp (length args)) ()
 335           "~s does not have an even number of arguments." `(setf ,args))
 336   `(progn ,@(loop for (place value) on args by #'cddr collect
 337                  (aif (and (listp place) (gethash (car place) *setf-expanders*))
 338                       (funcall it (cdr place) value)
 339                       `(ps-assign ,place ,value)))))
 340
 341 (defpsmacro psetf (&rest args)
 342   (let ((places (loop for x in args by #'cddr collect x))
 343         (vals (loop for x in (cdr args) by #'cddr collect x)))
 344     (let ((gensyms (loop repeat (length places) collect (ps-gensym))))
 345       `(let ,(mapcar #'list gensyms vals)
 346          (setf ,@(mapcan #'list places gensyms))))))
 347
 348 (defun check-setq-args (args)
 349   (let ((vars (loop for x in args by #'cddr collect x)))
 350     (let ((non-var (find-if (complement #'symbolp) vars)))
 351       (when non-var
 352         (error 'type-error :datum non-var :expected-type 'symbol)))))
 353
 354 (defpsmacro setq (&rest args)
 355   (check-setq-args args)
 356   `(setf ,@args))
 357
 358 (defpsmacro psetq (&rest args)
 359   (check-setq-args args)
 360   `(psetf ,@args))
 361
 362 ;;; iteration
 363
 364 (defun do-make-iteration-bindings (decls)
 365   (mapcar (lambda (x)
 366             (cond ((atom x) x)
 367                   ((endp (cdr x)) (list (car x)))
 368                   (t (subseq x 0 2))))
 369           decls))
 370
 371 (defun do-make-for-steps (decls)
 372   (mapcar (lambda (x)
 373             `(setf ,(first x) ,(third x)))
 374           (remove-if (lambda (x)
 375                        (or (atom x) (< (length x) 3)))
 376                      decls)))
 377
 378 (defun do-make-iter-psteps (decls)
 379   `(psetq
 380     ,@(mapcan (lambda (x)
 381                 (list (first x) (third x)))
 382               (remove-if (lambda (x)
 383                            (or (atom x) (< (length x) 3)))
 384                          decls))))
 385
 386 (defpsmacro do* (decls (end-test &optional (result nil result?)) &body body)
 387   `(block nil
 388      (for ,(do-make-iteration-bindings decls)
 389           ((not ,end-test))
 390           ,(do-make-for-steps decls)
 391           (locally ,@body))
 392      ,@(when result? (list result))))
 393
 394 (defpsmacro do (decls (end-test &optional (result nil result?)) &body body)
 395   (multiple-value-bind (do-body declarations)
 396       (parse-body body)
 397     `(block nil
 398        (let ,(do-make-iteration-bindings decls)
 399          ,@declarations
 400          (for () ((not ,end-test)) ()
 401               ,@do-body
 402               ,(do-make-iter-psteps decls))
 403          ,@(when result? (list result))))))
 404
 405 (defpsmacro dotimes ((var count &optional (result nil result?)) &rest body)
 406   `(do* ((,var 0 (1+ ,var)))
 407         ((>= ,var ,count)
 408          ,@(when result? `((let ((,var nil)) ,result))))
 409      ,@body))
 410
 411 (defpsmacro dolist ((var array &optional (result nil result?)) &body body)
 412   (let* ((idx (ps-gensym '_js_idx))
 413          (introduce-array-var? (not (symbolp array)))
 414          (arrvar (if introduce-array-var?
 415                      (ps-gensym '_js_arrvar)
 416                      array)))
 417     `(do* (,var
 418            ,@(when introduce-array-var?
 419                    (list (list arrvar array)))
 420            (,idx 0 (1+ ,idx)))
 421           ((>= ,idx (getprop ,arrvar 'length))
 422            ,@(when result? `((let ((,var nil)) ,result))))
 423        (setq ,var (aref ,arrvar ,idx))
 424        ,@body)))
 425
 426 ;;; Concatenation
 427
 428 (defpsmacro concatenate (result-type &rest sequences)
 429   (assert (equal result-type ''string) () "Right now Parenscript 'concatenate' only support strings.")
 430   (cons '+ sequences))
 431
 432 (defpsmacro append (arr1 &rest arrs)
 433   (if arrs
 434       `((@ ,arr1 concat) ,@arrs)
 435       arr1))
 436
 437 ;;; Destructuring bind
 438
 439 (defun complex-js-expr? (expr)
 440   (consp (if (symbolp expr) (ps-macroexpand expr) expr)))
 441
 442 (defun hoist-expr? (bindings expr)
 443   (and (> (length bindings) 1) (complex-js-expr? expr)))
 444
 445 (defun pop-declarations-for-var (var declarations)
 446   (loop for declarations* on declarations
 447         with var-declarations = nil
 448         do (setf (first declarations*)
 449                  (loop for spec in (first declarations*)
 450                        ;; We only care for SPECIAL declarations for now
 451                        ;; (cf. WITH-DECLARATION-EFFECTS)
 452                        if (and (consp spec) (eq 'special (first spec)))
 453                          collect
 454                            (let ((vars* (remove var (rest spec))))
 455                              (if (eq vars* (cdr spec))
 456                                  spec
 457                                  (progn
 458                                    (pushnew var (getf var-declarations 'special))
 459                                    (cons 'special vars*))))
 460                        else
 461                          collect spec))
 462         finally (return
 463                   (loop for (sym decls) on var-declarations by #'cddr
 464                         collect (cons sym decls)))))
 465
 466 (defun destructuring-wrap (arr n bindings declarations body)
 467   (cond ((null bindings) body)
 468         ((eq (car bindings) '&rest)
 469          (cond ((and (= (length bindings) 2) (atom (second bindings)))
 470                 `(let ((,(second bindings) (if (> (length ,arr) ,n) ((@ ,arr slice) ,n) '())))
 471                    (declare ,@(pop-declarations-for-var (second bindings) declarations))
 472                    ,body))
 473                (t (error "~a is invalid in destructuring list." bindings))))
 474         ((eq (car bindings) '&optional)
 475          (destructuring-wrap arr n (cdr bindings) declarations body))
 476         (t (let ((var (car bindings))
 477                  (inner-body (destructuring-wrap arr (1+ n) (cdr bindings) declarations body)))
 478              (cond ((null var) inner-body)
 479                    ((atom var) `(let ((,var (aref ,arr ,n)))
 480                                   (declare ,@(pop-declarations-for-var var declarations))
 481                                   ,inner-body))
 482                    (t `(,'destructuring-bind ,var (aref ,arr ,n)
 483                          ,@declarations
 484                          ,inner-body)))))))
 485
 486 (defpsmacro destructuring-bind (bindings expr &body body)
 487   (setf bindings (dot->rest bindings))
 488   (multiple-value-bind (body1 declarations) (parse-body body)
 489     (let* ((arr (if (hoist-expr? bindings expr) (ps-gensym '_db) expr))
 490            (bound (destructuring-wrap arr 0 bindings declarations
 491                                       (cons 'progn body1))))
 492       (cond ((eq arr expr) bound)
 493             (t `(let ((,arr ,expr)) ,bound))))))
 494
 495 ;;; Control structures
 496
 497 (defpsmacro return (&optional result)
 498   `(return-from nil ,result))
 499
 500 (defpsmacro ignore-errors (&body forms)
 501   (with-ps-gensyms (e)
 502     `(try (progn ,@forms)
 503           (:catch (,e) nil))))
 504
 505 (defpsmacro unwind-protect (protected-form cleanup-form)
 506   `(try ,protected-form
 507         (:finally ,cleanup-form)))
 508
 509 (defpsmacro prog1 (first &rest others)
 510   (with-ps-gensyms (val)
 511     `(let ((,val (multiple-value-list ,first)))
 512        ,@others
 513        (values-list ,val))))
 514
 515 (defpsmacro prog2 (first second &rest others)
 516   `(progn ,first (prog1 ,second ,@others)))
 517
 518 (defpsmacro apply (fn &rest args)
 519   (let ((arglist (if (> (length args) 1)
 520                      `(append (list ,@(butlast args)) ,(car (last args)))
 521                      (first args))))
 522     (if (and (listp fn)
 523              (find (car fn) #(getprop chain @)))
 524         (if (and (= (length fn) 3) (symbolp (second fn)))
 525             `(funcall (getprop ,fn 'apply) ,(second fn) ,arglist)
 526             (let ((obj (ps-gensym)) (method (ps-gensym)))
 527               `(let* ((,obj    ,(butlast fn))
 528                       (,method (,(car fn) ,obj ,(car (last fn)))))
 529                  (funcall (getprop ,method 'apply) ,obj ,arglist))))
 530         `(funcall (getprop ,fn 'apply) this ,arglist))))
 531
 532 ;;; misc
 533
 534 (defpsmacro let* (bindings &body body)
 535   (multiple-value-bind (let-body declarations) (parse-body body)
 536     (loop for binding in (cons nil (reverse bindings))
 537           for var = (if (symbolp binding) binding (car binding))
 538           for body = let-body
 539             then `((let (,binding)
 540                      (declare ,@(pop-declarations-for-var var declarations))
 541                      ,@body))
 542           finally (return `(progn ,@body)))))
 543
 544 (defpsmacro in-package (package-designator)
 545   `(eval-when (:compile-toplevel)
 546      (in-package ,package-designator)))
 547
 548 (defpsmacro use-package (package-designator &optional package)
 549   `(eval-when (:compile-toplevel)
 550      (use-package ,package-designator ,@(when package (list package)))))