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 ;;; Data structures
 149
 150 (defpsmacro make-array (&rest args)
 151   (or (ignore-errors
 152         (destructuring-bind (dim &key (initial-element nil initial-element-p)
 153                                  initial-contents element-type)
 154             args
 155           (declare (ignore element-type))
 156           (and (or initial-element-p initial-contents)
 157                (not (and initial-element-p initial-contents))
 158                (with-ps-gensyms (arr init elt i)
 159                  `(let ((,arr (new (*array ,dim))))
 160                     ,@(when initial-element-p
 161                         `((let ((,elt ,initial-element))
 162                             (dotimes (,i (length ,arr))
 163                               (setf (aref ,arr ,i) ,elt)))))
 164                     ,@(when initial-contents
 165                         `((let ((,init ,initial-contents))
 166                             (dotimes (,i (min (length ,arr) (length ,init)))
 167                               (setf (aref ,arr ,i) (aref ,init ,i))))))
 168                     ,arr)))))
 169       `(new (*array ,@args))))
 170
 171 (defpsmacro length (a)
 172   `(getprop ,a 'length))
 173
 174 ;;; Getters
 175
 176 (defpsmacro with-slots (slots object &rest body)
 177   (flet ((slot-var (slot)
 178            (if (listp slot)
 179                (first slot)
 180                slot))
 181          (slot-symbol (slot)
 182            (if (listp slot)
 183                (second slot)
 184                slot)))
 185     (maybe-once-only (object)
 186       `(symbol-macrolet ,(mapcar (lambda (slot)
 187                                    `(,(slot-var slot) (getprop ,object ',(slot-symbol slot))))
 188                                  slots)
 189          ,@body))))
 190
 191 ;;; multiple values
 192
 193 (defpsmacro multiple-value-bind (vars form &body body)
 194   (let* ((form (ps-macroexpand form))
 195          (progn-form
 196           (when (and (consp form)
 197                      (member
 198                       (car form)
 199                       '(with label let flet labels macrolet symbol-macrolet progn)))
 200             (pop form))))
 201     (if progn-form
 202         `(,progn-form
 203           ,@(butlast form)
 204           (multiple-value-bind ,vars
 205               ,@(last form)
 206             ,@body))
 207         ;; assume function call
 208         (with-ps-gensyms (prev-mv)
 209           (let* ((fun-exp (car form))
 210                  (funobj (if (symbolp fun-exp)
 211                              fun-exp
 212                              (ps-gensym 'funobj))))
 213             `(let (,@(unless (symbolp fun-exp) `((,funobj ,fun-exp)))
 214                    (,prev-mv (if (undefined __PS_MV_REG)
 215                                  (setf __PS_MV_REG undefined)
 216                                  __PS_MV_REG)))
 217                (try
 218                 (let ((,(car vars) (,funobj ,@(cdr form))))
 219                   (destructuring-bind (&optional ,@(cdr vars))
 220                       (if (eql ,funobj (@ __PS_MV_REG :tag))
 221                           (@ __PS_MV_REG :values)
 222                           (list))
 223                     ,@body))
 224                 (:finally (setf __PS_MV_REG ,prev-mv)))))))))
 225
 226 ;;; conditionals
 227
 228 (defpsmacro case (value &rest clauses)
 229   (labels
 230       ((make-switch-clause (val body more)
 231          (if (consp val)
 232              (append (mapcar #'list (butlast val))
 233                      (make-switch-clause
 234                       (if (eq t (car (last val))) ;; literal 'true'
 235                           '%true
 236                           (car (last val)))
 237                       body
 238                       more))
 239              `((,(cond ((member val '(t otherwise)) 'default)
 240                        ((eql val '%true)            t)
 241                        ((eql val 'false)            'false)
 242                        ((null val)                  'false)
 243                        ((symbolp val)               (list 'quote val))
 244                        (t                           val))
 245                  ,@body
 246                  ,@(when more '(break)))))))
 247     `(switch ,value
 248        ,@(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 (do-body declarations) (parse-body body)
 388     `(block nil
 389        (let ,(do-make-iteration-bindings decls)
 390          ,@declarations
 391          (for () ((not ,end-test)) ()
 392               ,@do-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 (body1 declarations) (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 body1))))
 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 (let-body declarations) (parse-body body)
 526     (loop for binding in (cons nil (reverse bindings))
 527           for var = (if (symbolp binding) binding (car binding))
 528           for body = let-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)))))