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