macros.lisp 20.4 KB
Newer Older
1
2
3
4
5
;;; Copyright 2005 Manuel Odendahl
;;; Copyright 2005-2006 Edward Marco Baringer
;;; Copyright 2006 Luca Capello
;;; Copyright 2010-2012 Vladimir Sedach
;;; Copyright 2010-2013 Daniel Gackle
6
;;; Copyright 2012, 2014 Boris Smilga
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38

;;; SPDX-License-Identifier: BSD-3-Clause

;;; Redistribution and use in source and binary forms, with or
;;; without modification, are permitted provided that the following
;;; conditions are met:

;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.

;;; 2. Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials provided
;;; with the distribution.

;;; 3. Neither the name of the copyright holder nor the names of its
;;; contributors may be used to endorse or promote products derived
;;; from this software without specific prior written permission.

;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;; POSSIBILITY OF SUCH DAMAGE.
39

40
(in-package #:parenscript)
41
(in-readtable :parenscript)
Vladimir Sedach's avatar
Vladimir Sedach committed
42
43
44
45
46
47
48

(macrolet ((define-trivial-mappings (&rest mappings)
             `(progn
                ,@(loop for (macro-name ps-op) on mappings by #'cddr collect
                       `(defpsmacro ,macro-name (&rest args)
                          (cons ',ps-op args))))))
  (define-trivial-mappings
49
50
51
52
53
54
55
56
    string= eql
    eq      eql
    =       eql
    list    array
    elt     aref))

(defpsmacro null (x)
  `(equal ,x nil))
Vladimir Sedach's avatar
Vladimir Sedach committed
57

58
59
60
61
62
63
64
65
;;; Math

(defmacro def-js-maths (&rest mathdefs)
  `(progn ,@(mapcar (lambda (def) (cons 'defpsmacro def)) mathdefs)))

(def-js-maths
    (max (&rest nums) `((@ *math max) ,@nums))
    (min (&rest nums) `((@ *math min) ,@nums))
66
67
68
69
70
71
    (floor (n &optional divisor)
      `((@ *math floor) ,(if divisor `(/ ,n ,divisor) n)))
    (ceiling (n &optional divisor)
      `((@ *math ceil) ,(if divisor `(/ ,n ,divisor) n)))
    (round (n &optional divisor)
      `((@ *math round) ,(if divisor `(/ ,n ,divisor) n)))
72
73
74
75
76
77
    (sin (n) `((@ *math sin) ,n))
    (cos (n) `((@ *math cos) ,n))
    (tan (n) `((@ *math tan) ,n))
    (asin (n) `((@ *math asin) ,n))
    (acos (n) `((@ *math acos) ,n))
    (atan (y &optional x) (if x `((@ *math atan2) ,y ,x) `((@ *math atan) ,y)))
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
    (sinh (x)
      (maybe-once-only (x)
        `(/ (- (exp ,x) (exp (- ,x))) 2)))
    (cosh (x)
      (maybe-once-only (x)
        `(/ (+ (exp ,x) (exp (- ,x))) 2)))
    (tanh (x)
      (maybe-once-only (x)
        `(/ (- (exp ,x) (exp (- ,x))) (+ (exp ,x) (exp (- ,x))))))
    (asinh (x)
      (maybe-once-only (x)
        `(log (+ ,x (sqrt (1+ (* ,x ,x)))))))
    (acosh (x)
      (maybe-once-only (x)
        `(* 2 (log (+ (sqrt (/ (1+ ,x) 2)) (sqrt (/ (1- ,x) 2)))))))
    (atanh (x) ;; real only for -1 < x < 1, otherwise complex
      (maybe-once-only (x)
        `(/ (- (log (+ 1 ,x)) (log (- 1 ,x))) 2)))
    (mod (x n)
      (maybe-once-only (n)
        `(rem (+ (rem ,x ,n) ,n) ,n)))
99
100
101
102
    (1+ (n) `(+ ,n 1))
    (1- (n) `(- ,n 1))
    (abs (n) `((@ *math abs) ,n))
    (evenp (n) `(not (oddp ,n)))
103
    (oddp (n) `(rem ,n 2))
104
105
106
107
108
109
110
111
    (exp (n) `((@ *math exp) ,n))
    (expt (base power) `((@ *math pow) ,base ,power))
    (log (n &optional base)
      (or (and (null base) `((@ *math log) ,n))
          (and (numberp base) (= base 10) `(* (log ,n) (@ *math *log10e*)))
          `(/ (log ,n) (log ,base))))
    (sqrt (n) `((@ *math sqrt) ,n))
    (random (&optional upto) (if upto
112
113
114
115
                                 (maybe-once-only (upto)
                                   `(if (rem ,upto 1)
                                        (* ,upto (random))
                                        (floor (* ,upto (random)))))
116
                                 '(funcall (@ *math random)))))
117

118
119
120
121
122
123
124
125
126
127
128
129
130
131
(defpsmacro ash (integer count)
  (let ((count (ps-macroexpand count)))
    (cond ((and (numberp count) (> count 0)) `(<< ,integer ,count))
          ((numberp count) `(>> ,integer ,(- count)))
          ((complex-js-expr? count)
           (let ((count-var (ps-gensym)))
             `(let ((,count-var ,count))
                (if (> ,count-var 0)
                    (<< ,integer ,count-var)
                    (>> ,integer (- ,count-var))))))
          (t `(if (> ,count 0)
                  (<< ,integer ,count)
                  (>> ,integer (- ,count)))))))

132
133
134
135
136
137
138
139
140
141
142
143
144
(define-ps-symbol-macro pi (getprop *math '*pi*))

;;; Types

(defpsmacro stringp (x)
  `(string= (typeof ,x) "string"))

(defpsmacro numberp (x)
  `(string= (typeof ,x) "number"))

(defpsmacro functionp (x)
  `(string= (typeof ,x) "function"))

Daniel Gackle's avatar
Daniel Gackle committed
145
146
147
(defpsmacro booleanp (x)
  `(string= (typeof ,x) "boolean"))

148
149
150
151
152
153
154
155
156
(defpsmacro listp (x)
  (if (js-target-at-least "1.8.5")
      `(funcall (getprop Array 'is-array) ,x)
      `(string= (funcall (getprop Object 'prototype 'to-string 'call) ,x)
                "[object Array]")))

(defpsmacro arrayp (x)
  `(listp ,x))

157
158
;;; Data structures

159
160
161
162
163
164
165
166
(defpsmacro make-array (&rest args)
  (or (ignore-errors
        (destructuring-bind (dim &key (initial-element nil initial-element-p)
                                 initial-contents element-type)
            args
          (declare (ignore element-type))
          (and (or initial-element-p initial-contents)
               (not (and initial-element-p initial-contents))
167
               (with-ps-gensyms (arr init elt i)
168
169
170
171
172
173
174
175
176
177
178
                 `(let ((,arr (new (*array ,dim))))
                    ,@(when initial-element-p
                        `((let ((,elt ,initial-element))
                            (dotimes (,i (length ,arr))
                              (setf (aref ,arr ,i) ,elt)))))
                    ,@(when initial-contents
                        `((let ((,init ,initial-contents))
                            (dotimes (,i (min (length ,arr) (length ,init)))
                              (setf (aref ,arr ,i) (aref ,init ,i))))))
                    ,arr)))))
      `(new (*array ,@args))))
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193

(defpsmacro length (a)
  `(getprop ,a 'length))

;;; Getters

(defpsmacro with-slots (slots object &rest body)
  (flet ((slot-var (slot)
           (if (listp slot)
               (first slot)
               slot))
         (slot-symbol (slot)
           (if (listp slot)
               (second slot)
               slot)))
194
195
196
197
198
    (maybe-once-only (object)
      `(symbol-macrolet ,(mapcar (lambda (slot)
                                   `(,(slot-var slot) (getprop ,object ',(slot-symbol slot))))
                                 slots)
         ,@body))))
199

Vladimir Sedach's avatar
Vladimir Sedach committed
200
201
;;; multiple values

202
203
(defpsmacro multiple-value-bind (vars form &body body)
  (let* ((form (ps-macroexpand form))
204
205
206
207
208
209
         (progn-form
          (when (and (consp form)
                     (member
                      (car form)
                      '(with label let flet labels macrolet symbol-macrolet progn)))
            (pop form))))
210
211
    (if progn-form
        `(,progn-form
Daniel Gackle's avatar
Daniel Gackle committed
212
213
214
215
          ,@(butlast form)
          (multiple-value-bind ,vars
              ,@(last form)
            ,@body))
216
        ;; assume function call
217
        (with-ps-gensyms (prev-mv)
218
219
220
          (let* ((fun-exp (car form))
                 (funobj (if (symbolp fun-exp)
                             fun-exp
221
                             (ps-gensym 'funobj))))
Daniel Gackle's avatar
Daniel Gackle committed
222
223
224
225
226
227
228
229
230
231
232
233
            `(let (,@(unless (symbolp fun-exp) `((,funobj ,fun-exp)))
                   (,prev-mv (if (undefined __PS_MV_REG)
                                 (setf __PS_MV_REG undefined)
                                 __PS_MV_REG)))
               (try
                (let ((,(car vars) (,funobj ,@(cdr form))))
                  (destructuring-bind (&optional ,@(cdr vars))
                      (if (eql ,funobj (@ __PS_MV_REG :tag))
                          (@ __PS_MV_REG :values)
                          (list))
                    ,@body))
                (:finally (setf __PS_MV_REG ,prev-mv)))))))))
Vladimir Sedach's avatar
Vladimir Sedach committed
234
235
236
237

;;; conditionals

(defpsmacro case (value &rest clauses)
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
  (labels
      ((make-switch-clause (val body more)
         (if (consp val)
             (append (mapcar #'list (butlast val))
                     (make-switch-clause
                      (if (eq t (car (last val))) ;; literal 'true'
                          '%true
                          (car (last val)))
                      body
                      more))
             `((,(cond ((member val '(t otherwise)) 'default)
                       ((eql val '%true)            t)
                       ((eql val 'false)            'false)
                       ((null val)                  'false)
                       ((symbolp val)               (list 'quote val))
                       (t                           val))
                 ,@body
                 ,@(when more '(break)))))))
    `(switch ,value
       ,@(mapcon (lambda (clause)
                   (make-switch-clause (car (first clause))
                                       (cdr (first clause))
                                       (rest clause)))
                 clauses))))
Vladimir Sedach's avatar
Vladimir Sedach committed
262
263

(defpsmacro when (test &rest body)
264
  `(if ,test (progn ,@body)))
Vladimir Sedach's avatar
Vladimir Sedach committed
265
266

(defpsmacro unless (test &rest body)
267
  `(when (not ,test) ,@body))
Vladimir Sedach's avatar
Vladimir Sedach committed
268
269
270
271
272
273
274
275
276
277
278
279

;;; function definition

(defpsmacro defun (name lambda-list &body body)
  "An extended defun macro that allows cool things like keyword arguments.
lambda-list::=
 (var*
  [&optional {var | (var [init-form [supplied-p-parameter]])}*]
  [&rest var]
  [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
  [&aux {var | (var [init-form])}*])"
  (if (symbolp name)
Red Daly's avatar
Red Daly committed
280
281
      (progn (setf (gethash name *function-lambda-list*) lambda-list)
             `(defun% ,name ,lambda-list ,@body))
Vladimir Sedach's avatar
Vladimir Sedach committed
282
283
      (progn (assert (and (listp name) (= (length name) 2) (eq 'setf (car name))) ()
                     "(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list)
Vladimir Sedach's avatar
Vladimir Sedach committed
284
             `(defun-setf ,(second name) ,lambda-list ,@body))))
Vladimir Sedach's avatar
Vladimir Sedach committed
285
286
287

;;; defining setf expanders

288
(defvar *defun-setf-name-prefix* '__setf_)
Vladimir Sedach's avatar
Vladimir Sedach committed
289

Vladimir Sedach's avatar
Vladimir Sedach committed
290
(defpsmacro defun-setf (name lambda-list &body body)
Vladimir Sedach's avatar
Vladimir Sedach committed
291
  (let ((mangled-function-name
Vladimir Sedach's avatar
Vladimir Sedach committed
292
293
294
295
296
         (intern (format nil "~A~A" (string *defun-setf-name-prefix*) (string name))
                 (symbol-package name))))
    (setf (gethash name *setf-expanders*)
          (lambda (access-args store-form)
            `(,mangled-function-name ,store-form ,@access-args)))
Vladimir Sedach's avatar
Vladimir Sedach committed
297
298
299
300
    `(defun ,mangled-function-name ,lambda-list ,@body)))

;;; slightly broken WRT lambda lists
(defpsmacro defsetf-long (access-fn lambda-list (store-var) form)
301
  (setf (gethash access-fn *setf-expanders*)
Vladimir Sedach's avatar
Vladimir Sedach committed
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
        (compile
         nil
         (let ((var-bindings (ordered-set-difference lambda-list
                                                     lambda-list-keywords)))
           `(lambda (access-fn-args store-form)
              (destructuring-bind ,lambda-list
                  access-fn-args
                (let* ((,store-var (ps-gensym))
                       (gensymed-names (loop repeat ,(length var-bindings)
                                          collecting (ps-gensym)))
                       (gensymed-arg-bindings (mapcar #'list
                                                      gensymed-names
                                                      (list ,@var-bindings))))
                  (destructuring-bind ,var-bindings
                      gensymed-names
                    `(let* (,@gensymed-arg-bindings
                            (,,store-var ,store-form))
                       ,,form))))))))
  nil)

(defpsmacro defsetf-short (access-fn update-fn &optional docstring)
  (declare (ignore docstring))
324
  (setf (gethash access-fn *setf-expanders*)
Vladimir Sedach's avatar
Vladimir Sedach committed
325
326
327
328
329
330
331
332
333
334
335
336
337
        (lambda (access-fn-args store-form)
          `(,update-fn ,@access-fn-args ,store-form)))
  nil)

(defpsmacro defsetf (access-fn &rest args)
  `(,(if (= (length args) 3) 'defsetf-long 'defsetf-short) ,access-fn ,@args))

;;; setf

(defpsmacro setf (&rest args)
  (assert (evenp (length args)) ()
          "~s does not have an even number of arguments." `(setf ,args))
  `(progn ,@(loop for (place value) on args by #'cddr collect
338
                 (aif (and (listp place) (gethash (car place) *setf-expanders*))
Vladimir Sedach's avatar
Vladimir Sedach committed
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
                      (funcall it (cdr place) value)
                      `(ps-assign ,place ,value)))))

(defpsmacro psetf (&rest args)
  (let ((places (loop for x in args by #'cddr collect x))
        (vals (loop for x in (cdr args) by #'cddr collect x)))
    (let ((gensyms (loop repeat (length places) collect (ps-gensym))))
      `(let ,(mapcar #'list gensyms vals)
         (setf ,@(mapcan #'list places gensyms))))))

(defun check-setq-args (args)
  (let ((vars (loop for x in args by #'cddr collect x)))
    (let ((non-var (find-if (complement #'symbolp) vars)))
      (when non-var
        (error 'type-error :datum non-var :expected-type 'symbol)))))

(defpsmacro setq (&rest args)
  (check-setq-args args)
  `(setf ,@args))

(defpsmacro psetq (&rest args)
  (check-setq-args args)
  `(psetf ,@args))

;;; iteration

Daniel Gackle's avatar
Daniel Gackle committed
365
(defun do-make-iteration-bindings (decls)
Vladimir Sedach's avatar
Vladimir Sedach committed
366
  (mapcar (lambda (x)
Daniel Gackle's avatar
Daniel Gackle committed
367
368
369
            (cond ((atom x) x)
                  ((endp (cdr x)) (list (car x)))
                  (t (subseq x 0 2))))
Vladimir Sedach's avatar
Vladimir Sedach committed
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
          decls))

(defun do-make-for-steps (decls)
  (mapcar (lambda (x)
            `(setf ,(first x) ,(third x)))
          (remove-if (lambda (x)
                       (or (atom x) (< (length x) 3)))
                     decls)))

(defun do-make-iter-psteps (decls)
  `(psetq
    ,@(mapcan (lambda (x)
                (list (first x) (third x)))
              (remove-if (lambda (x)
                           (or (atom x) (< (length x) 3)))
                         decls))))

Daniel Gackle's avatar
Daniel Gackle committed
387
(defpsmacro do* (decls (end-test &optional (result nil result?)) &body body)
388
  `(block nil
Daniel Gackle's avatar
Daniel Gackle committed
389
390
     (for ,(do-make-iteration-bindings decls)
          ((not ,end-test))
391
          ,(do-make-for-steps decls)
392
          (locally ,@body))
393
     ,@(when result? (list result))))
Vladimir Sedach's avatar
Vladimir Sedach committed
394

Daniel Gackle's avatar
Daniel Gackle committed
395
(defpsmacro do (decls (end-test &optional (result nil result?)) &body body)
396
397
  (multiple-value-bind (do-body declarations)
      (parse-body body)
398
399
400
401
    `(block nil
       (let ,(do-make-iteration-bindings decls)
         ,@declarations
         (for () ((not ,end-test)) ()
402
              ,@do-body
403
404
              ,(do-make-iter-psteps decls))
         ,@(when result? (list result))))))
Vladimir Sedach's avatar
Vladimir Sedach committed
405
406
407

(defpsmacro dotimes ((var count &optional (result nil result?)) &rest body)
  `(do* ((,var 0 (1+ ,var)))
408
409
        ((>= ,var ,count)
         ,@(when result? `((let ((,var nil)) ,result))))
Vladimir Sedach's avatar
Vladimir Sedach committed
410
411
412
     ,@body))

(defpsmacro dolist ((var array &optional (result nil result?)) &body body)
413
  (let* ((idx (ps-gensym '_js_idx))
Vladimir Sedach's avatar
Vladimir Sedach committed
414
415
         (introduce-array-var? (not (symbolp array)))
         (arrvar (if introduce-array-var?
416
                     (ps-gensym '_js_arrvar)
Vladimir Sedach's avatar
Vladimir Sedach committed
417
418
419
420
421
422
                     array)))
    `(do* (,var
           ,@(when introduce-array-var?
                   (list (list arrvar array)))
           (,idx 0 (1+ ,idx)))
          ((>= ,idx (getprop ,arrvar 'length))
423
           ,@(when result? `((let ((,var nil)) ,result))))
Vladimir Sedach's avatar
Vladimir Sedach committed
424
425
426
       (setq ,var (aref ,arrvar ,idx))
       ,@body)))

427
428
429
430
431
432
433
434
435
436
437
438
439
;;; Concatenation

(defpsmacro concatenate (result-type &rest sequences)
  (assert (equal result-type ''string) () "Right now Parenscript 'concatenate' only support strings.")
  (cons '+ sequences))

(defpsmacro append (arr1 &rest arrs)
  (if arrs
      `((@ ,arr1 concat) ,@arrs)
      arr1))

;;; Destructuring bind

440
441
442
443
444
445
(defun complex-js-expr? (expr)
  (consp (if (symbolp expr) (ps-macroexpand expr) expr)))

(defun hoist-expr? (bindings expr)
  (and (> (length bindings) 1) (complex-js-expr? expr)))

446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
(defun pop-declarations-for-var (var declarations)
  (loop for declarations* on declarations
        with var-declarations = nil
        do (setf (first declarations*)
                 (loop for spec in (first declarations*)
                       ;; We only care for SPECIAL declarations for now
                       ;; (cf. WITH-DECLARATION-EFFECTS)
                       if (and (consp spec) (eq 'special (first spec)))
                         collect
                           (let ((vars* (remove var (rest spec))))
                             (if (eq vars* (cdr spec))
                                 spec
                                 (progn
                                   (pushnew var (getf var-declarations 'special))
                                   (cons 'special vars*))))
                       else
                         collect spec))
        finally (return
                  (loop for (sym decls) on var-declarations by #'cddr
                        collect (cons sym decls)))))

(defun destructuring-wrap (arr n bindings declarations body)
468
469
470
471
  (cond ((null bindings) body)
        ((eq (car bindings) '&rest)
         (cond ((and (= (length bindings) 2) (atom (second bindings)))
                `(let ((,(second bindings) (if (> (length ,arr) ,n) ((@ ,arr slice) ,n) '())))
472
                   (declare ,@(pop-declarations-for-var (second bindings) declarations))
473
474
475
                   ,body))
               (t (error "~a is invalid in destructuring list." bindings))))
        ((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
481
482
483
484
485
                   ((atom var) `(let ((,var (aref ,arr ,n)))
                                  (declare ,@(pop-declarations-for-var var declarations))
                                  ,inner-body))
                   (t `(,'destructuring-bind ,var (aref ,arr ,n)
                         ,@declarations
                         ,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
494
      (cond ((eq arr expr) bound)
            (t `(let ((,arr ,expr)) ,bound))))))
495
496
497

;;; Control structures

498
499
(defpsmacro return (&optional result)
  `(return-from nil ,result))
500

501
502
503
504
(defpsmacro ignore-errors (&body forms)
  (with-ps-gensyms (e)
    `(try (progn ,@forms)
          (:catch (,e) nil))))
505

Vladimir Sedach's avatar
Vladimir Sedach committed
506
507
508
509
(defpsmacro unwind-protect (protected-form cleanup-form)
  `(try ,protected-form
        (:finally ,cleanup-form)))

510
511
512
513
514
515
516
517
518
519
520
521
522
(defpsmacro prog1 (first &rest others)
  (with-ps-gensyms (val)
    `(let ((,val ,first))
       ,@others
       ,val)))

(defpsmacro prog2 (first second &rest others)
  `(progn ,first (prog1 ,second ,@others)))

(defpsmacro apply (fn &rest args)
  (let ((arglist (if (> (length args) 1)
                     `(append (list ,@(butlast args)) ,(car (last args)))
                     (first args))))
523
524
525
526
527
528
529
530
531
    (if (and (listp fn)
             (find (car fn) #(getprop chain @)))
        (if (and (= (length fn) 3) (symbolp (second fn)))
            `(funcall (getprop ,fn 'apply) ,(second fn) ,arglist)
            (let ((obj (ps-gensym)) (method (ps-gensym)))
              `(let* ((,obj    ,(butlast fn))
                      (,method (,(car fn) ,obj ,(car (last fn)))))
                 (funcall (getprop ,method 'apply) ,obj ,arglist))))
        `(funcall (getprop ,fn 'apply) this ,arglist))))
532

533
;;; misc
Vladimir Sedach's avatar
Vladimir Sedach committed
534
535

(defpsmacro let* (bindings &body body)
536
  (multiple-value-bind (let-body declarations) (parse-body body)
537
538
    (loop for binding in (cons nil (reverse bindings))
          for var = (if (symbolp binding) binding (car binding))
539
          for body = let-body
540
541
542
543
            then `((let (,binding)
                     (declare ,@(pop-declarations-for-var var declarations))
                     ,@body))
          finally (return `(progn ,@body)))))
544
545
546
547
548
549
550
551

(defpsmacro in-package (package-designator)
  `(eval-when (:compile-toplevel)
     (in-package ,package-designator)))

(defpsmacro use-package (package-designator &optional package)
  `(eval-when (:compile-toplevel)
     (use-package ,package-designator ,@(when package (list package)))))