src/macros.lisp

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