src/macros.lisp

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